→	This version of the UCI LISP compiler is based on a LISP 1.6 compiler
→	copied from COMPLR[LSP,LSP] at SAIL on 8/3/76.	A number of bugs
→	in the Stanford compiler were located and corrected, and to my
→	knowledge it is now bug-free (sounds challenging, doesn't it --
→	note the qualifier, however).  The modifications to the original
→	Stanford code were rather extensive, and I gave up trying to mark
→	them.  All changes which were made solely to acclimate the compiler
→	to a UCI LISP environment are marked with "→***" comments.
→
→					- Rick LeFaivre
→					  Computer Science Dept.
→					  Rutgers University








(DEFP BEGINBLOCK NILL FSUBR)					→***
 
(DEFP ENDBLOCK NILL FSUBR)					→***
 
(BEGINBLOCK COMPILER)
 
(DECLARE (SPECIAL LASTOUT LOCVARS SPECVARS P1CNT P2CNT FUNNAME)
	 (SPECIAL CURLOCVS RENAMELIST INPROG P1SCNT FOUNDFREE)
	 (SPECIAL LISTING MSGCHAN INDEV OUTDEV OUTEXT INLSUBR)
	 (SPECIAL ACS PDL PDLDEPTH MINDEPTH)
	 (SPECIAL LDLST PRGSPFLG PROGVARS SPLDLST CCLST RSL CTAG)
	 (SPECIAL VARLIST GOLIST EXIT EXITN PRSSL PROGSW VGO PVR)
	 (SPECIAL NACS VALUEAC ALLACS GOTABAC FARGAC ARRAYAC)
	 (SPECIAL ALLFUNS GENFUNS UNDFUNS CODESIZE CONSTSIZE)
	 (SPECIAL IBASE BASE *NOPOINT INUM0)
	 (SPECIAL TRACELIST SHOWNAMES)
	 (SPECIAL LAPLST LAPKLST DEBUGXPR SPECIALS)		→***
	 (*FSUBR COMPERR USERERR))
 
(BEGINBLOCK MACROS)
 
(DEFPROP DFUNC
	 (LAMBDA (L)
		 (LIST (Q DEFPROP)
		       (CAADR L)
		       (MCONS (Q LAMBDA) (CDADR L) (CDDR L))
		       (Q EXPR)))
	 MACRO)
 
(DEFPROP FIRSTPROP (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
 
(DEFPROP FLUSHDEF (LAMBDA (L) (CONS (Q FLUSHEXPR) (CDR L))) MACRO)
 
(DEFPROP GENTAG (LAMBDA (L) (Q (NEXTSYM (Q TAG)))) MACRO)
 
(DEFPROP GENVAL (LAMBDA (L) (Q (NEXTSYM (Q VAL)))) MACRO)
 
(DEFPROP GENVAR (LAMBDA (L) (Q (NEXTSYM (Q VAR)))) MACRO)
 
(DEFPROP GETPROP (LAMBDA (L) (CONS (Q GET) (CDR L))) MACRO)
 
(DEFPROP IFIF
 (LAMBDA (L)
	 (LIST (Q COND) (CDR L) (LIST T (CONS (Q NOT) (CDDR L)))))
 MACRO)
 
(DEFPROP INCR
 (LAMBDA (L)
	 (LIST (QUOTE SETQ) (CADR L) (LIST (QUOTE ADD1) (CADR L))))
 MACRO)
 








(DEFPROP LASTPROP (LAMBDA (L) (CONS (Q NULL) (CDR L))) MACRO)
 
(DEFPROP MAPDEF
 (LAMBDA (L)
	 (LIST (Q MAPCAR)
	       (SUBST (CADR L)
		      (Q IND)
		      (Q (FUNCTION (LAMBDA (PAIR)
					   (PUTPROP (CAR PAIR)
						    (CADR PAIR)
						    (QUOTE IND))))))
	       (LIST (Q QUOTE) (CDDR L))))
 MACRO)
 
(DEFPROP MCONS
 (LAMBDA (L)
	 (COND ((NULL (CDDR L)) (CADR L))
	       (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
 MACRO)
 
(DEFPROP NEXTPROP (LAMBDA (L) (CONS (Q CDDR) (CDR L))) MACRO)
 
(DEFPROP OUTINST (LAMBDA (INST) (CONS (Q OUTSTAT) (CDR INST))) MACRO)
 
(DEFPROP OUTPSOP (LAMBDA (PSOP) (CONS (Q OUTSTAT) (CDR PSOP))) MACRO)
 
(DEFPROP OUTTAG (LAMBDA (TAG) (CONS (Q OUTSTAT) (CDR TAG))) MACRO)
 
(DEFPROP PDLDEPTH (LAMBDA (L) (Q PDLDEPTH)) MACRO)
 
(DEFPROP PROPNAM (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)
 
(DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CADR) (CDR L))) MACRO)
 
(DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)
 
(DEFPROP SETPROP
 (LAMBDA (L) (LIST (Q PUTPROP) (CADR L) (CADDDR L) (CADDR L)))
MACRO)
 
(DEFPROP TAGP (LAMBDA (L) (CONS (Q ATOM) (CDR L))) MACRO)
 
(DEFPROP USERWARN
	 (LAMBDA (L)
		 (LIST (Q PRINTMSG)
		       (LIST (Q APPEND)
			     (LIST (Q LIST) (CADR L))
			     (LIST (Q Q) (APPEND (CDDR L) (Q (IN))))
			     (Q (LIST (CURFUN))))))
	 MACRO)
 
(ENDBLOCK MACROS)








(BEGINBLOCK TOPLEVEL)
 
(DFUNC (ACTONEXPR XPR)
       (PROG (ACTION)
	     (COND ((ATOM XPR) (GO FLUSH)))
	     (SETQ ACTION (GETGET (CAR XPR) (Q COMPEFFECT)))
	     (COND (ACTION ((PROPVAL ACTION) XPR) (RETURN NIL)))
	FLUSH(FLUSHEXPR XPR)
	     (RETURN NIL)))
 
(DFUNC (ACTONMACRO XPR)
       (ACTONEXPR ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
 
(DEFPROP CMP
 (LAMBDA (L)
  (COND	((NULL L) NIL)
	((NULL (CDR L)) (COMPILEFUN (CAR L)))
	(T (PUTPROP (CAAR L)
		    (MCONS (Q LAMBDA) (CDAR L) (CDR L))
		    (Q EXPR))					→***
	   (COMPILEFUN (CAAR L)))))
 FEXPR)
 
(DFUNC (COMPDEF DEFIN)
 (PROG (ACTION)
       (COND ((NOT (EQUAL (LENGTH DEFIN) 4))
	      (USERERR ARGNOERR-COMPDEF)))
       (COND ((SETQ ACTION (SEEKPROP (CADDDR DEFIN) (Q DEFACTION)))
	      ((PROPVAL ACTION) DEFIN)
	      (RETURN NIL)))
       (FLUSHDEF DEFIN)
       (RETURN NIL)))
 
(DFUNC (COMPFILE INFILE OUTFILE)
       (PROG (ALLFUNS UNDFUNS GENFUNS CODESIZE CONSTSIZE STARTTIME)
	     (SETQ STARTTIME (TIME))
	     (SETQ CODESIZE (SETQ CONSTSIZE 0))
	     (DOFILE (FUNCTION COMPREADS) INFILE OUTFILE)
	     (TELLTALE (CADR INFILE) STARTTIME)))








(DFUNC (COMPFUNC NAME EXPR FLAG)
 (PROG (LOCVARS SPECVARS P1EXP P1CNT P2CNT LASTOUT INLSUBR)
       (INITSYM (Q TAG))
       (INITSYM (Q VAL))
       (INITSYM (Q VAR))
       (INITSYM (Q SUBFUN))
       (INITPROP (Q CURFUN) (Q NAME) NAME)
       (SETQ P1EXP (PASS1 EXPR))
       (DEINITSYM (Q SUBFUN))
       (TERPRI)
       (OUTPSOP (LIST (Q LAP) NAME FLAG))
       (COND ((EQ (CAR EXPR) (Q FSUBR))
	      (COND ((NOT (NULL (CDADR EXPR)))
		     (OUTINST (Q (PUSHJ P *AMAKE))))))
	     ((EQ (CAR EXPR) (Q LSUBR))
	      (OUTINST (Q (JSP 3 *LCALL)))
	      (SETQ INLSUBR T)))
       (PASS2 P1EXP)
       (TERPRI)
       (DELETEPROP (Q CURFUN) (Q NAME))
       (COND ((NOT (EQUAL P2CNT P1CNT))
	      (PRINTMSG (LIST P1CNT P2CNT))
	      (COMPERR COUNTSDISAGREE-COMPFUNC)))
       (DEINITSYM (Q TAG))
       (DEINITSYM (Q VAL))
       (DEINITSYM (Q VAR))
       (RETURN NAME)))
 
(DEFPROP COMPILE
 (LAMBDA (NAMES)
  (PROG (DONE)
   LOOP	(COND ((NULL NAMES) (OUTC NIL T) (RETURN DONE)))
	(COND ((NOT (ATOM (CAR NAMES)))
	       (OUTC (EVAL (CONS (Q OUTPUT) (CAR NAMES))) NIL))
	      (T (SETQ DONE (NCONC DONE (COMPILEFUN (CAR NAMES))))))
	(SETQ NAMES (CDR NAMES))
	(GO LOOP)))
 FEXPR)








(DFUNC (COMPILEFUN NAME)
 (PROG (GENFUNS UNDFUNS CODESIZE CONSTSIZE MSGCHAN SHOWNAMES PROP
	DONE PLIST)
       (SETQ CODESIZE (SETQ CONSTSIZE 0))
       (SETQ PLIST (CDR NAME))
  LOOP (COND ((NULL PLIST) (RETURN (REVERSE DONE))))
       (SETQ PROP (SEEKPROP (CAR PLIST) (Q DEFACTION)))
       (COND ((NULL PROP) (GO ELOOP)))
       (SETQ DONE (CONS (CONS NAME (CAR PLIST)) DONE))
       ((PROPVAL PROP)
	(LIST (Q DEFPROP) NAME (CADR PLIST) (CAR PLIST)))
  ELOOP(SETQ PLIST (CDDR PLIST))
       (GO LOOP)))
 
(DEFPROP COMPL
 (LAMBDA (FILES)
  (PROG (MSGCHAN)
	(COND ((NOT (NULL LISTING))
	       (SETQ MSGCHAN (EVAL (MCONS (Q OUTPUT)
					  (GENSYM)
					  LISTING)))))
   LOOP	(COND ((NULL FILES) (OUTC MSGCHAN NIL)
			    (OUTC NIL T)
			    (RETURN NIL)))
	(COND ((%DEVP (CAR FILES))				→***
	       (SETQ INDEV (CAR FILES))
	       (GO ELOOP)))
	(COMPFILE (LIST INDEV (CAR FILES))
		  (LIST	OUTDEV
			(CONS (COND ((ATOM (CAR FILES)) (CAR FILES))
				    (T (CAAR FILES)))
			      OUTEXT)))
   ELOOP(SETQ FILES (CDR FILES))
	(GO LOOP)))
 FEXPR)
 
(DFUNC (COMPREADS) (READLOOP (FUNCTION ACTONEXPR)))
 
(DFUNC (CURFUN) (GETPROP (Q CURFUN) (Q NAME)))
 
(DEFPROP DECLARE (LAMBDA (L) (MAPC (FUNCTION EVAL) L)) FEXPR)








(DFUNC (DEFEXPR DEF)
 (PROG (FN EX)
       (TYPEFN (SETQ FN (CADR DEF)))
       (SETQ EX (CADDR DEF))
       (COND ((OR (ATOM EX) (NOT (EQ (CAR EX) (Q LAMBDA))))
	      (FLUSHDEF DEF))
	     ((AND (ATOM (CADR EX)) (NOT (NULL (CADR EX))))
	      (COND ((REMPROP FN (Q *UNDEF))
		     (PRINTMSG (CONS FN (Q (LSUBR USED AS SUBR))))))
	      (PUTPROP FN T (Q *LSUBR))
	      (COMPFUNC	FN
			(MCONS (Q LSUBR) (LIST (CADR EX)) (CDDR EX))
			(Q LSUBR)))
	     (T	(REMPROP FN (Q *UNDEF))
		(PUTPROP FN T (Q *SUBR))
		(COMPFUNC FN (CONS (Q SUBR) (CDR EX)) (Q SUBR))))))
 
(DFUNC (DEFFEXPR DEF)
       (PROG (FN EX)
	     (TYPEFN (SETQ FN (CADR DEF)))
	     (SETQ EX (CADDR DEF))
	     (COND ((REMPROP FN (Q *UNDEF))
		    (PRINTMSG (CONS FN (Q (FSUBR USED AS SUBR))))))
	     (PUTPROP FN T (Q *FSUBR))
	     (COMPFUNC FN (CONS (Q FSUBR) (CDR EX)) (Q FSUBR))))
 
(DFUNC (DEFMACRO DEF)
 (PROG NIL
       (TYPEFN (CADR DEF))
       (COND ((REMPROP (CADR DEF) (Q *UNDEF))
	      (PRINTMSG (CONS (CADR DEF) (Q (MACRO USED AS SUBR))))))
       (PUTPROP (CADR DEF) (CADDR DEF) (Q MACRO))
       (COND [(GET (CADR DEF) @GLOBALMACRO) (FLUSHDEF DEF)])))
 
(DFUNC (DO*EXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *SUBR)))
 
(DFUNC (DO*FEXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *FSUBR)))
 
(DFUNC (DO*LEXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *LSUBR)))
 
(DFUNC (DOACT XPR) ((GETPROP (CAR XPR) (Q COMPACTION)) XPR))
 
(DFUNC (DODE L)
       (DEFEXPR (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q EXPR))))
 
(DFUNC (DODF L)
       (DEFFEXPR (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q FEXPR))))
 
(DFUNC (DODM L)
       (DEFMACRO (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q MACRO))))








(DFUNC (DOFILE DOREADS INFILE OUTFILE)
       (PROG NIL
	     (EVAL (MCONS (Q INPUT) (Q INCHAN) INFILE))
	     (EVAL (MCONS (Q OUTPUT) (Q OUTCHAN) OUTFILE))
	     (INC (Q INCHAN) NIL)
	     (OUTC (Q OUTCHAN) NIL)
	     (DOREADS)
	     (OUTC NIL T)
	     (INC NIL T)))
 
(DFUNC (FLUSHEXPR EXPR)
       (TERPRI)
       (SPRINT EXPR 1)					→***
       (TERPRI))
 
(DFUNC (FLUSHLAP ENTRY)
       (PROG (NAME FLAG TYPE STAT)
	     (TYPEFN (SETQ NAME (CADR ENTRY)))
	     (SETQ FLAG (CADDR ENTRY))
	     (SETQ TYPE	(ASSOC FLAG
			       (Q ((FSUBR *FSUBR) (LSUBR *LSUBR)
						  (SUBR *SUBR)))))
	     (COND ((NULL TYPE) (GO PRINT)))
	     (SETQ TYPE (CADR TYPE))
	     (COND ((AND (MEMQ TYPE (Q (*FSUBR *LSUBR)))
			 (GETPROP NAME (Q *UNDEF)))
		    (PRINTMSG (MCONS NAME FLAG (Q (USED AS SUBR))))))
	     (SETPROP NAME TYPE T)
	     (REMPROP NAME (Q *UNDEF))
       PRINT (TERPRI)
	     (OUTPUTSTAT ENTRY)
	LOOP (SETQ STAT (ERRSET (READ)))
	     (COND ((ATOM STAT) (USERERR READERR-FLUSHLAP)))
	     (OUTPUTSTAT (CAR STAT))
	     (COND ((NULL (CAR STAT)) (TERPRI) (RETURN NIL)))
	     (GO LOOP)))
 
(DFUNC (MAKDEF NAME ARGS BODY TYPE)
       (LIST (Q DEFPROP) NAME (LIST (Q LAMBDA) ARGS BODY) TYPE))
 
(DFUNC (MAPPUT EXP)
       (PROG (IND ARGS)
	     (SETQ IND (CAR EXP))
	     (SETQ ARGS (CDR EXP))
	LOOP (COND ((NULL ARGS) (RETURN EXP)))
	     (PUTPROP (CAR ARGS) T IND)
	     (SETQ ARGS (CDR ARGS))
	     (GO LOOP)))
 
(DFUNC (PRINTMSG MESSAGE)
       (PROG (CHAN)
	     (SETQ CHAN (OUTC MSGCHAN NIL))
	     (COND ((NOT (ATMARGIN)) (LINEF 2)))
	     (PRINL (CONS (Q *) MESSAGE))
	     (LINEF 1)
	     (OUTC CHAN NIL)))








(DFUNC (READLOOP ACTFUN)
       (PROG (EXPR)
	LOOP (SETQ EXPR (ERRSET (READ)))
	     (COND ((EQ EXPR (Q $EOF$)) (RETURN NIL)))
	     (ACTFUN (CAR EXPR))
	     (GO LOOP)))
 
(DEFPROP SPECIAL
	 (LAMBDA (X) (MAPCAR (FUNCTION MAKESPECIAL) X))
	 FEXPR)
 
(DFUNC (TELLTALE FILENAME STARTTIME)
 (PROG (CHAN UNDS)
       (SETQ CHAN (OUTC MSGCHAN NIL))
       (CARRETN)
       (LINEF 1)
       (PRINL (LIST FILENAME (Q COMPILED)))
       (PRINL (LIST CODESIZE (Q WORDS)))
       (PRINL (LIST CONSTSIZE (Q CONSTANTS)))
       (PRINL (LIST (ADD1 (QUOTIENT (DIFFERENCE (TIME) STARTTIME)
				    1750))
		    (Q SECONDS)))
       (LINEF 2)
  UNDF (COND ((NULL UNDFUNS) (GO UNDF1)))
       (COND ((HASPROP (CAR UNDFUNS) (Q *UNDEF))
	      (SETQ UNDS (CONS (CAR UNDFUNS) UNDS))))
       (SETQ UNDFUNS (CDR UNDFUNS))
       (GO UNDF)
  UNDF1(COND ((NULL UNDS) (GO GENF)))
       (PRINL (Q (UNDEFINED FUNCTIONS)))
       (LINEF 1)
       (PRINL UNDS)
       (LINEF 2)
  GENF (COND ((NULL GENFUNS) (GO END)))
       (PRINL (Q (GENERATED FUNCTIONS)))
       (LINEF 1)
       (PRINL GENFUNS)
       (LINEF 2)
  END  (OUTC CHAN NIL)))
 
(DFUNC (TYPEFN MESSAGE)
       (PROG (CHAN)
	     (COND ((NULL SHOWNAMES) (RETURN NIL)))
	     (SETQ CHAN (OUTC MSGCHAN NIL))
	     (COND ((ATMARGIN) (LINEF 1)))
	     (PRINS MESSAGE)
	     (OUTC CHAN NIL)))
 
(DEFPROP UNSPECIAL
	 (LAMBDA (X) (MAPCAR (FUNCTION MAKEUNSPECIAL) X))
	 FEXPR)
 








(BEGINBLOCK INITIALIZATION)
 
(PROGN				→*** NO NEED TO COMPILE THIS
(DE CINIT NIL
       (SETQ LAPLST (SETQ LAPKLST NIL))
       (NOUUO NIL)
       (GCGAG NIL)
       (GC)
       (SYSCLR)				→***
       (INITFN @CSTART))
 
(DE CSTART NIL
 (PROG NIL
       (REMOB CINIT CSTART)
       (INITFN NIL)
				→*** INIT FILE NOW READ BY SYSTEM
       (LINEF 1)
       (PRINC @"RUTGERS/UCI LISP COMPILER - 1/22/77")		→***
       (TERPRI)))
)
 
(ENDBLOCK INITIALIZATION)
 
(MAPDEF COMPEFFECT (COMPACTION DOACT) (MACRO ACTONMACRO))
 
(MAPDEF COMPACTION (DE DODE) (DECLARE EVAL) (DEFPROP COMPDEF)
		   (DF DODF) (DM DODM) (LAP FLUSHLAP) (SPECIAL EVAL)
		   (UNSPECIAL EVAL) (*SUBR EVAL) (*FSUBR EVAL)
		   (*LSUBR EVAL) (*EXPR EVAL) (*FEXPR EVAL)
		   (*LEXPR EVAL) (NOCALL EVAL) (CALL EVAL)	   →***
		   (NOCOMPILE IGNORE) (* IGNORE) (** IGNORE)	   →***
		   (*** IGNORE) (GLOBALMACRO EVAL))		   →***
 
 
(MAPDEF DEFACTION (EXPR DEFEXPR) (FEXPR DEFFEXPR) (MACRO DEFMACRO)
		  (SPECIAL EVAL) (DEFACTION EVAL) (*EXPR DO*EXPR)
		  (*FEXPR DO*FEXPR) (*LEXPR DO*LEXPR) (*SUBR EVAL)
		  (*FSUBR EVAL) (*LSUBR EVAL)
		  (NOCALL EVALFLUSH) (CALL FLUSHEXPR))		   →***
 
(SETQ MSGCHAN NIL)
 
(SETQ LISTING NIL)
 
(SETQ OUTDEV (SETQ INDEV (QUOTE DSK:)))
 
(SETQ OUTEXT (QUOTE LAP))
 
(SETQ SHOWNAMES T)
 
(ENDBLOCK TOPLEVEL)








(BEGINBLOCK PASS1)
 
(DFUNC (DOP1 XPR) ((GETPROP (CAR XPR) (Q P1)) XPR))
 
(DFUNC (GENFUN EXPR)
 (PROG (NAME ARGS CALL)
       (COND ((ATOM EXPR) (RETURN EXPR)))
       (COND ((NOT (EQ (CAR EXPR) (Q LAMBDA)))
	      (USERERR NOTFUNCTION-GENFUN)))
       (SETQ ARGS (CADR EXPR))
       (SETQ CALL (CADDR EXPR))
       (COND ((AND (ATOM (CAR CALL)) (EQUAL ARGS (CDR CALL)))
	      (RETURN (CAR CALL))))
       (SETQ NAME (MAKESYM (NEXTSYM (Q SUBFUN)) (CURFUN)))
       (SETQ GENFUNS (CONS NAME GENFUNS))
       (RETURN (COMPFUNC NAME (LIST (Q SUBR) ARGS CALL) (Q SUBR)))))
 
(DFUNC (MAPP1 ARGS) (MAPCAR (FUNCTION P1) ARGS))
 
(DFUNC (NEWNAME OLD)
       (PROG (NEW)
	     (SETQ NEW (ASSOC OLD RENAMELIST))
	     (COND (NEW (RETURN (CDR NEW))))
	     (RETURN NIL)))
 
(DFUNC (P1 XPR)
 (PROG (TEM)
       (SETQ DEBUGXPR XPR)
       (COND ((ATOM XPR) (GO ATOM)))
       (COND ((ATOM (CAR XPR)) (GO ATOMC)))
       (COND ((EQ (CAAR XPR) (Q LAMBDA)) (RETURN (P1LAM XPR))))
       (COND ((EQ (CAAR XPR) (Q LABEL)) (RETURN (P1LABEL XPR))))
       (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
  ATOM (COND ((CONSTANTP XPR) (RETURN (LIST (Q QUOTE) XPR))))
       (COND ((SETQ TEM (NEWNAME XPR)) (RETURN (P1 TEM))))
       (INCR P1CNT)
       (COND ((SPECIALP XPR) (SETQ SPECVARS (ADDTOLIST XPR SPECVARS))
			     (RETURN XPR)))
       (COND ((VARB XPR) (RETURN XPR)))
       (PUTLOC XPR P1CNT)
       (RETURN XPR)
  ATOMC(COND ((CONSTANTP (CAR XPR)) (USERERR CONSTFUN-P1)))
       (COND ((SETQ TEM (NEWNAME (CAR XPR)))
	      (RETURN (P1 (CONS TEM (CDR XPR))))))
       (COND ((SETQ TEM (GETGET (CAR XPR) (Q PASS1)))
	      (RETURN ((PROPVAL TEM) XPR))))
       (COND ((OR (SPECIALP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
	      (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))))
       (RETURN (P1ELSE XPR))))
 
→*** (P1ANDOR Removed)








(DFUNC (P1BIND VARS)
 (PROG (VAR NEWVARS)
       (COND ((AND VARS (ATOM VARS)) (USERERR ATOMICVARLIST-P1BIND)))
  LOOP (COND ((NULL VARS) (RETURN (REVERSE NEWVARS))))
       (SETQ VAR (CAR VARS))
       (COND ((NOT (VARIABLEP VAR)) (USERERR NOTVARIABLE-P1BIND)))
       (COND ((MEMBER VAR NEWVARS) (USERWARN VAR REPEATED VARIABLE)))
       (COND ((SPECIALP VAR) (SETQ SPECVARS (ADDTOLIST VAR SPECVARS))
			     (GO ELOOP))
	     ((ASSOC VAR LOCVARS) (RENAME VAR (SETQ VAR (GENVAR)))))
       (PUTLOC VAR 0)
       (SETQ CURLOCVS (CONS VAR CURLOCVS))
  ELOOP(SETQ NEWVARS (CONS VAR NEWVARS))
       (SETQ VARS (CDR VARS))
       (GO LOOP)))
 
(DFUNC (P1BUG LOW HIGH PTR)
       (PROG (X)
	LOOP (COND ((NULL PTR) (RETURN NIL)))
	     (SETQ X (CAR PTR))
	     (COND ((GREATERP (CDR X) LOW) (RPLACD X HIGH)))
	     (SETQ PTR (CDR PTR))
	     (GO LOOP)))
 
(DFUNC (P1COND XPR)
       (PROG (TEM CT PAIRS)
	     (SETQ TEM LOCVARS)
	     (SETQ CT P1CNT)
	     (INCR P1CNT)
	     (SETQ PAIRS (MAPCAR (FUNCTION MAPP1) (CDR XPR)))
	     (INCR P1CNT)
	     (P1BUG CT P1CNT TEM)
	     (INCR P1CNT)
	     (RETURN (CONS (CAR XPR) PAIRS))))
 
(DFUNC (P1CONS XPR)
       (COND ((NOT (EQ (LENGTH (CDR XPR)) 2)) (USERERR ARGNO-P1CONS))
	     ((NULL (CADDR XPR)) (LIST (Q NCONS) (P1 (CADR XPR))))
	     (T (LIST (Q CONS) (P1 (CADR XPR)) (P1 (CADDR XPR))))))
 
(DFUNC (P1ELSE XPR)
       (PROG NIL
	     (SETQ UNDFUNS (CONS (CAR XPR) UNDFUNS))
	     (PUTPROP (CAR XPR) T (Q *UNDEF))
	     (RETURN (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))))
 
→*** (P1ERRSET Removed)








(DFUNC (P1EVAL XPR)
       (PROG (CDRXPR)
	     (SETQ CDRXPR (P1SUBRARGS (CDR XPR)))
	     (COND ((NOT (NULL (CDR CDRXPR)))
		    (RETURN (CONS (Q EVAL) CDRXPR))))
	     (RETURN (CONS (Q *EVAL) CDRXPR))))
 
(DFUNC (P1FUNCTION XPR)
       (LIST (COND ((EQ (CAR XPR) (Q FUNCTION)) (Q QUOTE)) (T (CAR XPR)))
	     (GENFUN (CADR XPR))))
 
(DFUNC (P1GO XPR)
       (PROG NIL
	     (COND ((NOT INPROG) (USERERR NOTINPROG-P1GO)))
	     (COND ((ATOM (CADR XPR)) (RETURN XPR)))
	     (RETURN (LIST (CAR XPR) (P1 (CADR XPR))))))
 
(DFUNC (P1LABEL XPR)
 (PROG (FN)
       (INITPROP (CADAR XPR) (Q FUNVAR) T)
       (SETQ FN (P1 (LIST (Q FUNCTION) (CADDAR XPR))))
       (DELETEPROP (CADAR XPR) (Q FUNVAR))
       (RETURN (P1 (LIST (Q PROG)
			 (LIST (CADAR XPR))
			 (LIST (Q SETQ) (CADAR XPR) FN)
			 (LIST (Q RETURN)
			       (CONS (CADAR XPR) (CDR XPR))))))))
 
(DFUNC (P1LAM XPR)
 ((LAMBDA (RENAMELIST CURLOCVS)
       (PROG (ARGS LAML BODY)
	     (SETQ ARGS (P1SUBRARGS (CDR XPR)))
	     (SETQ LAML (P1BIND (CADAR XPR)))
	     (SETQ BODY (P1 (CADDRLAM (CAR XPR))))		→***
	     (INCR P1CNT)
	     (RETURN (CONS (LIST (Q LAMBDA) LAML BODY) ARGS))))
  RENAMELIST
  CURLOCVS))
 
 








(DFUNC (P1PROG XPR)
 ((LAMBDA (RENAMELIST CURLOCVS)
   (PROG (TAGLIST P1SCNT PR TEM P1LL INPROG)
       (COND ((NULL (CDR XPR)) (USERERR PROGTOOSHORT-P1PROG)))
       (SETQ INPROG T)
       (SETQ XPR (CDR XPR))
       (SETQ P1LL (P1BIND (CAR XPR)))
       (SETQ TEM LOCVARS)
       (SETQ P1SCNT (INCR P1CNT))
  LOOP1(SETQ XPR (CDR XPR))
       (COND ((NULL XPR) (GO END1)))
       (INCR P1CNT)
       (COND ((ATOM (CAR XPR))
	      (COND ((ASSOC (CAR XPR) TAGLIST)
		     (USERWARN (CAR XPR) MULTIPLY DEFINED TAG)))
	      (SETQ TAGLIST (CONS (CONS (CAR XPR) (GENTAG)) TAGLIST))
	      (SETQ PR (CONS (CAR XPR) PR)))
	     (T (SETQ PR (CONS (P1 (CAR XPR)) PR))))
       (GO LOOP1)
  END1 (INCR P1CNT)
       (P1BUG P1SCNT P1CNT TEM)
       (SETQ TEM (GETPROP (Q LOCVARS) (Q VALUE)))
  LOOP (COND ((NULL (CDR TEM)) (GO END)))
       (COND ((AND (MEMBER (CAADR TEM) P1LL) (ZEROP (CDADR TEM)))
	      (USERWARN (CAADR TEM) UNUSED PROG VARIABLE)
	      (SETQ SPECVARS (ADDTOLIST (CAADR TEM) SPECVARS))
	      (SETQ SPECIALS (ADDTOLIST (CAADR TEM) SPECIALS))
	      (MAKESPECIAL (CAADR TEM))))
  ELOOP(SETQ TEM (CDR TEM))
       (GO LOOP)
  END  (INCR P1CNT)
       (RETURN (MCONS (Q PROG) TAGLIST P1LL (REVERSE PR)))))
  RENAMELIST
  CURLOCVS))
 
(DFUNC (P1RETURN XPR)
 (COND ((NOT INPROG) (USERERR NOTINPROG-P1RETURN))
       (T (LIST	(Q RETURN)
		(P1 (COND ((NULL (CDR XPR)) NIL) (T (CADR XPR))))))))
 
(DFUNC (P1SETQ XPR)
 (PROG (VAR TEM VAL)
       (COND ((NOT (VARIABLEP (CADR XPR)))
	      (USERERR NOTVARIABLE-P1SETQ)))
       (SETQ VAR (COND ((SETQ TEM (NEWNAME (CADR XPR))) TEM)
		       (T (CADR XPR))))
       (VARB VAR)
       (SETQ VAL (P1 (CADDR XPR)))
       (INCR P1CNT)
       (INCR P1CNT)
       (RETURN (LIST (Q SETQ) VAR VAL))))
 
 








(DFUNC (P1STORE XPR)
       (PROG (ARG1 ARG2)
	     (SETQ ARG2 (P1 (CADDR XPR)))
	     (SETQ ARG1 (P1 (CADR XPR)))
	     (RETURN (LIST (CAR XPR) ARG1 ARG2))))
 
(DFUNC (P1SUBRARGS ARGS)
 (COND ((GREATERP (LENGTH ARGS) NACS) (USERERR EXTRAARGS-P1SUBRARGS))
       (T (MAPP1 ARGS))))
 
(DFUNC (PASS1 EXPR)
 (PROG (CURLOCVS LL RENAMELIST P1SCNT INPROG FOUNDFREE LOCVS)
       (SETQ P1CNT 1)
       (SETQ DEBUGXPR EXPR)
       (SETQ LOCVARS (SETQ SPECVARS NIL))
       (SETQ LL (P1BIND (CADR EXPR)))
       (COND ((GREATERP (LENGTH LL) NACS) (USERERR EXTRAARGS-PASS1)))
       (SETQ EXPR (LIST (CAR EXPR) LL (P1 (CADDRLAM EXPR))))	→***
       (COND ((NOT (NULL FOUNDFREE)) (USERWARN (REVERSE FOUNDFREE)
					       UNDECLARED
					       FREE
					       VARIABLES)))
       (SETQ LOCVS LOCVARS)
       (SETQ LOCVARS NIL)
  LOOP (COND ((NULL LOCVS) (RETURN EXPR)))
       (COND ((NOT (SPECIALP (CAAR LOCVS)))
	      (SETQ LOCVARS (CONS (CAR LOCVS) LOCVARS))
	      (SETPROP (CAAR LOCVS) (Q LOCAL) T))
	     (T (SETQ SPECVARS (ADDTOLIST (CAAR LOCVS) SPECVARS))))
       (SETQ LOCVS (CDR LOCVS))
       (GO LOOP)))
 
(DFUNC (PASS1FSUBR XPR) XPR)
 
(DFUNC (PASS1FUNVAR XPR)
       (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
 
(DFUNC (PASS1LSUBR XPR) (CONS (CAR XPR) (MAPP1 (CDR XPR))))
 
(DFUNC (PASS1MACRO XPR) (P1 ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
 
(DFUNC (PASS1SUBR XPR) (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))
 
(DFUNC (PASS1UNDEF XPR)
       (PROG2 (SETQ UNDFUNS (ADDTOLIST (CAR XPR) UNDFUNS))
	      (PASS1SUBR XPR)))
 
 








(DFUNC (PUTLOC IVAR NUMBER)
 (PROG (TEM)
       (SETQ TEM (ASSOC IVAR LOCVARS))
       (COND (TEM (RETURN (RPLACD TEM NUMBER))))
       (RETURN (SETQ LOCVARS (CONS (CONS IVAR NUMBER) LOCVARS)))))
 
(DFUNC (RENAME OLD NEW)
       (SETQ RENAMELIST (CONS (CONS OLD NEW) RENAMELIST)))
 
(DFUNC (SPECIALP VAR) (HASPROP VAR (Q SPECIAL)))
 
(DFUNC (VARB X)
       (PROG NIL
	     (COND ((MEMBER X CURLOCVS) (RETURN NIL))
		   ((SPECIALP X) (GO SPEC)))
	     (SETQ FOUNDFREE (CONS X FOUNDFREE))
	     (SETQ SPECIALS (CONS X SPECIALS))
	     (MAKESPECIAL X)
	SPEC (SETQ SPECVARS (ADDTOLIST X SPECVARS))
	     (RETURN T)))
 
(DFUNC (VARIABLEP EX) (AND (ATOM EX) (NOT (CONSTANTP EX))))
 
(MAPDEF PASS1 (EXPR PASS1SUBR) (*EXPR PASS1SUBR) (SUBR PASS1SUBR)
	      (*SUBR PASS1SUBR) (*UNDEF PASS1UNDEF) (*LEXPR PASS1LSUBR)
	      (LSUBR PASS1LSUBR) (*LSUBR PASS1LSUBR)
	      (FEXPR PASS1FSUBR) (*FEXPR PASS1FSUBR)
	      (FSUBR PASS1FSUBR) (*FSUBR PASS1FSUBR) (P1 DOP1)
	      (FUNVAR PASS1FUNVAR) (MACRO PASS1MACRO))
 
(MAPDEF P1 (COND P1COND) (GO P1GO) (PROG P1PROG) (EVAL P1EVAL)
	   (SETQ P1SETQ) (STORE P1STORE)
	   (CONS P1CONS) (*FUNCTION P1FUNCTION) (FUNCTION P1FUNCTION)
	   (RETURN P1RETURN))
→***	   ((ERRSET P1ERRSET), (AND P1ANDOR), and (OR P1ANDOR) Removed)
 
(SETQ SPECIALS NIL)
 
(SETQ PDL (SETQ ACS (SETQ LDLST (SETQ SPLDLST NIL))))








(BEGINBLOCK INTERNALMACROS)
 
(DEFPROP INMACRO PASS1INMACRO PASS1)
 
(DFUNC (PASS1INMACRO XPR) (P1 ((GETPROP (CAR XPR) (Q INMACRO)) XPR)))
 
(DEFPROP INMACRO
 (LAMBDA (DF)
  (COMPFUNC (CADR DF) (CONS (Q SUBR) (CDADDR DF)) (Q INMACRO)))
 DEFACTION)
 
(DEFPROP APPEND
 (LAMBDA (L)
  (COND	((NULL (CDR L)) NIL)
	((NULL (CDDR L)) (CADR L))
	(T (LIST (Q *APPEND) (CADR L) (CONS (CAR L) (CDDR L))))))
 INMACRO)
 
(DEFPROP LIST
 (LAMBDA (L)
	 (COND ((NULL (CDR L)) NIL)
	       ((NULL (CDDR L)) (CONS (Q NCONS) (CDR L)))
	       (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
 INMACRO)
 
(DEFPROP NOT (LAMBDA (L) (CONS (Q NULL) (CDR L))) INMACRO)
 
(DEFPROP ZEROP (LAMBDA (L) (LIST (Q EQ) (CADR L) (Q 0))) INMACRO)
 
(ENDBLOCK INTERNALMACROS)
 
(ENDBLOCK PASS1)








(BEGINBLOCK PASS2)
 
(DFUNC (ACEFFECTS FN)
 (COND ((SETQ FN (SEEKPROP FN (Q ACS))) (PROPVAL FN)) (T ALLACS)))
 
(DFUNC (ACNUMP X)
       (AND (NUMBERP X) (GREATERP X 0) (LESSP X (ADD1 NACS))))
 
(DFUNC (BINDVARS VARS LAMBDAP)
       (PROG (VAR ACNUM SPFLG)
	     (SETQ ACNUM 1)
	A    (COND ((NULL VARS) (RETURN SPFLG)))
	     (SETQ VAR (CAR VARS))
	     (COND ((SPECVARP VAR) (GO SP1))
		   ((ASSOC VAR LOCVARS) (GO LV1))
		   (T (COMPERR FUNNYVAR-BINDVARS) (GO SP2)))
	LV1  (COND (LAMBDAP (SETSLOT ACNUM (LIST VAR))))
	SP2  (SETQ ACNUM (ADD1 ACNUM))
	     (SETQ VARS (CDR VARS))
	     (GO A)
	SP1  (COND ((NOT PRGSPFLG) (GO B)))
	SP3  (OUTINST (LIST 0
			    (COND (LAMBDAP ACNUM) (T 0))
			    (LIST (Q SPECIAL) VAR)
			    (Q S)))				→***
	     (GO LV1)
	B    (SETQ PRGSPFLG (SETQ SPFLG T))
	     (OUTINST (Q (JSP 6 SPECBIND)))
	     (GO SP3)))
 
→*** (BOOLAND Removed)
 
(DFUNC (BOOLCOND EXP VALAC TAG FLAG)
       (PROGN (INCR P2CNT)
	      (P2COND1 (CDR EXP) VALAC NIL FLAG TAG)
	      (INCR P2CNT)
	      (INCR P2CNT)
	      (RSLSET TAG)))








(DFUNC (BOOLEQ EXP VALAC TAG FLAG)
       (PROGN (BOOLEQ1 (CDR EXP) VALAC TAG FLAG)
	      (OUTJRST TAG)
	      (RSLSET TAG)))
 
(DFUNC (BOOLEQ1 EXP VALAC TAG F)
 (PROG (ARG1 ARG2 LOC1 LOC2 AC MEM)
       (COND ((NOT (EQ (LENGTH EXP) 2)) (USERERR ARGNOERR-BOOLEQ1)))
       (SETQ ARG1 (COMP (CAR EXP) (FREEAC)))
       (SETQ ARG2 (COMP (CADR EXP) (FREEAC)))
       (SETQ LOC2 (LOC ARG2))
       (SETQ LOC1 (LOC ARG1))
       (RST TAG)
       (COND ((ACNUMP LOC1) (SETQ AC LOC1) (SETQ MEM (LOC ARG2)))
	     ((ACNUMP LOC2) (SETQ AC LOC2) (SETQ MEM (LOC ARG1)))
	     (T	(LOADARG (SETQ AC (FREEAC)) ARG1)
		(SETQ MEM (LOC ARG2))))
       (REMOVE ARG1)
       (REMOVE ARG2)
       (SAVEACS)
       (OUT1 (COND (F (Q CAMN)) (T (Q CAME))) AC MEM)))
 
(DFUNC (BOOLEXPR EXP VALAC TAG FLAG MINDEPTH)
       (PROG (TEM)
	     (COND ((ATOM EXP) (GO ELSE)))
	     (COND ((SETQ TEM (SEEKPROP (CAR EXP) (Q BOOL)))
		    (RETURN ((PROPVAL TEM) EXP VALAC TAG FLAG))))
	ELSE (SETQ EXP (PUTINAC	(COMP EXP VALAC) VALAC))
	     (OUTCJMP FLAG EXP TAG)
	     (COND (FLAG (RSLSET TAG) (SETSLOT EXP (Q (QUOTE NIL))))
		   (T (SETQ FLAG (SLOTCONT EXP))
		      (SETSLOT EXP (Q (QUOTE NIL)))
		      (RSLSET TAG)
		      (SETSLOT EXP FLAG)))))
 
→*** (BOOL2 Removed)
 
(DFUNC (BOOLNULL EXP VALAC TAG FLAG)
       (BOOLEXPR (CADR EXP) VALAC TAG (NOT FLAG) MINDEPTH))
 
→*** (BOOLOR Removed)
 
(DFUNC (BOOLQUOTE EXP VALAC TAG FLAG)				→***
       (COND ((EQ FLAG (NOT (NULL (CADR EXP))))
	      (OUTJRST TAG)
	      (RSLSET TAG))))
 
(DFUNC (BOOLVALUE VALAC EFFECTS TAG)
 (PROG NIL
       (COND ((NOT EFFECTS) (OUT1 (Q TDZA) VALAC VALAC)))
       (OUTENDTAG TAG)
       (COND ((NOT EFFECTS) (OUT1 (Q MOVEI) VALAC (Q (QUOTE T)))))
       (RETURN (MARKVAL VALAC EFFECTS))))








(DFUNC (CALLFSUBR XPR VALAC EFFECTS)
       (PROG (FUN ARGS VAL)
	     (SETQ FUN (CAR XPR))
	     (SETQ ARGS (CDR XPR))
	     (CLEAR2BOTH)
	     (LOADARG FARGAC (LIST (Q QUOTE) ARGS))
	     (PROTECTACS FUN)
	     (SETQ VAL (MARKVAL VALUEAC EFFECTS))
	     (OUTCALL 17 FUN)
	     (RETURN VAL)))
 
(DFUNC (CALLFUNARGS XPR VALAC EFFECTS)
       (PROG (FUN ARGS FUNARGS LOCS VAL)
	     (SETQ FUN (CAR XPR))
	     (SETQ ARGS (CDR XPR))
	     (SETQ FUNARGS (COMP FUN VALAC))
	     (SETQ LOCS (COMPARGS ARGS))
	     (CLRCCLST LOCS)
	     (LOADSUBRARGS LOCS)
	     (CLEAR2BOTH)
	     (CLEARACS)
	     (SETQ VAL (MARKVAL VALUEAC EFFECTS))
	     (OUTCALLF (LENGTH LOCS) (LOC FUNARGS))
	     (REMOVE FUNARGS)
	     (RETURN VAL)))
 
(DFUNC (CALLLSUBR XPR VALAC EFFECTS)
       (PROG (FUN ARGS NARGS HOME INST RETTAG TEM VAL)
	     (SETQ FUN (CAR XPR))
	     (SETQ ARGS (CDR XPR))
	     (CLEAR1)
	     (SETQ NARGS (LENGTH ARGS))
	     (SLOTPUSH (Q (NIL . TAKEN)))
	     (OUTPUSH (GENCONST 0 0 (SETQ RETTAG (GENTAG)) 0))
	LOOP (COND ((NULL ARGS) (GO CALL)))
	     (SETQ HOME (TOPCOPY PDL))
	     (SETQ INST (COMP (CAR ARGS) VALAC))
	     (RESTORE HOME)
	     (SETQ TEM (LOC INST))
	     (SLOTPUSH (Q (NIL . TAKEN)))
	     (OUTPUSH TEM)
	     (REMOVE INST)
	     (SETQ ARGS (CDR ARGS))
	     (GO LOOP)
	CALL (SETQ TEM (PDLDEPTH))
	     (SAVEACS)
	     (COND ((NOT (EQ (PDLDEPTH) TEM))
		    (COMPERR PDLTOOLONG-LSUBRCALL)))
	     (OUTINST (LIST (Q MOVNI) 6 NARGS))
	LLOOP(SLOTPOP)
	     (COND ((ZEROP NARGS) (GO CALL1)))
	     (SETQ NARGS (SUB1 NARGS))
	     (GO LLOOP)
	CALL1(CLEAR2BOTH)
	     (CLEARACS)
	     (SETQ VAL (MARKVAL VALUEAC EFFECTS))
	     (OUTJCALL 16 FUN)
	     (OUTTAG RETTAG)
	     (RETURN VAL)))








(DFUNC (CALLSUBR XPR VALAC EFFECTS)
       (PROG (FUN ARGS NARGS LOCS TEM VAL)
	     (SETQ FUN (CAR XPR))
	     (SETQ ARGS (CDR XPR))
	     (SETQ LOCS (COMPARGS ARGS))
	     (SETQ NARGS (LENGTH LOCS))
	     (COND ((AND (SETQ TEM (SEEKPROP FUN (Q COMMU)))
			 (EQ NARGS 2)
			 (EQ (ILOC (CAR LOCS) VALUEAC) VALUEAC))
		    (SETQ LOCS (REVERSE LOCS))
		    (SETQ FUN (PROPVAL TEM))))
	     (SETQ TEM (SIDEEFFECTS FUN))
	     (COND (TEM (CLRCCLST LOCS)))
	     (LOADSUBRARGS LOCS)
	     (COND (TEM (CLEAR2BOTH)))
	     (PROTECTACS FUN)
	     (SETQ VAL (MARKVAL VALUEAC EFFECTS))
	     (OUTCALL NARGS FUN)
	     (RETURN VAL)))
 
(DFUNC (CLEAR1) (PROGN (CLEAR1BOTH) (SAVEACS) (CLRPVARS)))
 
(DFUNC (CLEAR1BOTH) (PROG NIL (CLRCCLST1 VALUEAC) (CLRSPLD)))
 
(DFUNC (CLEAR2BOTH) (PROG NIL (CLRCCLST2 VALUEAC) (CLRSPLD)))
 
(DFUNC (CLEARAC ACNO) (PROG NIL (CPUSH ACNO) (SETSLOT ACNO NIL)))
 
(DFUNC (CLEARITALL) (PROG NIL (CLEAR2BOTH) (CLEARACS)))
 
(DFUNC (CLEARACS)
       (PROG (ACNO)
	     (SETQ ACNO NACS)
	LOOP (COND ((ZEROP ACNO) (RETURN NIL)))
	     (CLEARAC ACNO)
	     (SETQ ACNO (SUB1 ACNO))
	     (GO LOOP)))
 
(DFUNC (CLRCCLST DATA)
       (PROG (CCL)
	     (SETQ CCL CCLST)
	LOOP (COND ((NULL CCL) (RETURN NIL)))
	     (COND ((ASSOC (CAAR CCL) DATA) (GO ELOOP)))
	     (CSFUN (CAR CCL) VALUEAC)
	ELOOP(SETQ CCL (CDR CCL))
	     (GO LOOP)))
 
 








(DFUNC (CLRCCLST1 AC)
       (PROG (CCL)
	     (SETQ CCL CCLST)
	LOOP (COND ((NULL CCL) (RETURN NIL)))
	     (CSFUN (CAR CCL) AC)
	     (SETQ CCL (CDR CCL))
	     (GO LOOP)))
 
(DFUNC (CLRCCLST2 AC)
       (PROG NIL
	LOOP (COND ((NULL CCLST) (RETURN NIL)))
	     (CSFUN (CAR CCLST) AC)
	     (SETQ CCLST (CDR CCLST))
	     (GO LOOP)))
 
(DFUNC (CLRPVARS)
       (PROG NIL
	     (COND ((NOT PROGSW) (RETURN NIL)))
	     (SETQ PROGSW NIL)
	LOOP (COND ((NULL PROGVARS) (SETQ PRSSL (TOPCOPY PDL))
				    (SETQ MINDEPTH (PDLDEPTH))
				    (RETURN NIL)))
	     (INITZ (CAR PROGVARS))
	     (SETQ PROGVARS (CDR PROGVARS))
	     (GO LOOP)))
 
(DFUNC (CLRSPLD)
       (PROG NIL
	LOOP (COND ((NULL SPLDLST) (RETURN NIL)))
	     (CLRSPVAR (CAAR SPLDLST))
	     (SETQ SPLDLST (CDR SPLDLST))
	     (GO LOOP)))
 
(DFUNC (CLRSPVAR VAR)
 (PROG (LOC L)
       (SETQ LOC (ILOC (SETQ L (CONS VAR P2CNT)) VALUEAC))
       (COND ((NOT (NUMBERP LOC))
	      (SLOTPUSH L)
	      (OUTPUSH (LIST (Q SPECIAL) VAR)))
	     ((ACNUMP LOC) (SLOTPUSH L) (OUTPUSH LOC)))
       (RETURN NIL)))
 
(DFUNC (COMP XPR VALAC) (COMPEXPR XPR VALAC NIL))
 
(DFUNC (COMPARGS ARGS)
       (PROG (ARGNO RESULT)
	     (SETQ ARGNO 0)
	LOOP (COND ((NULL ARGS) (RETURN RESULT)))
	     (SETQ ARGNO (ADD1 ARGNO))
	     (SETQ RESULT (CONS (COMP (CAR ARGS) ARGNO) RESULT))
	     (SETQ ARGS (CDR ARGS))
	     (GO LOOP)))
 
 








(DFUNC (COMPE XPR VALAC) (REMOVE (COMPEXPR XPR VALAC T)))
 
(DFUNC (COMPEXPR XPR VALAC EFFECTS)
 (PROG (TEM)
       (SETQ DEBUGXPR XPR)
       (COND ((ATOM XPR) (GO ATOM)))
       (COND ((ATOM (CAR XPR)) (GO ATOMC)))
       (COND ((EQ (CAAR XPR) (Q LAMBDA))
	      (RETURN (INTERNALLAMBDA XPR VALAC EFFECTS))))
       (RETURN (CALLFUNARGS XPR VALAC EFFECTS))
  ATOM (INCR P2CNT)
       (COND ((MEMQ XPR PROGVARS) (RETURN (Q (QUOTE NIL)))))
       (SETQ TEM (CONS XPR P2CNT))
       (COND ((SPECVARP XPR) (SETQ SPLDLST (CONS TEM SPLDLST))))
       (SETQ LDLST (CONS TEM LDLST))
       (RETURN TEM)
  ATOMC(COND ((SETQ TEM (GETGET (CAR XPR) (Q PASS2)))
	      (RETURN ((PROPVAL TEM) XPR VALAC EFFECTS))))
       (COND ((OR (SPECVARP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
	      (RETURN (CALLFUNARGS XPR VALAC EFFECTS))))
       (RETURN (P2ELSE XPR VALAC EFFECTS))))
 
(DFUNC (COPT FUN AC ARGLOC)
       (PROG (CCL TEM YLOC)
	     (SETQ YLOC (ILOC ARGLOC AC))
	     (SETQ CCL CCLST)
	LOOP (COND ((NULL CCL) (RETURN NIL))
		   ((AND (EQ FUN (CADAR CCL))
			 (EQUAL (ILOC (CDDAR CCL) AC) YLOC)
			 (ILOC (SETQ TEM (LIST (CAAR CCL))) AC))
		    (RETURN TEM)))
	     (SETQ CCL (CDR CCL))
	     (GO LOOP)))
 
 








(DFUNC (CPUSH ACNO)
 (PROG (TEMPDL SLOTNO SLOTCON HOLDSLOT)
       (COND ((NOT (DVP (SETQ SLOTCON (SLOTCONT ACNO))))
	      (RETURN NIL)))
       (COND ((LESSP ACNO 1) (GO MAKE)))
  START(SETQ SLOTNO 0)
       (SETQ TEMPDL PDL)
  LOOP (COND ((NULL TEMPDL) (GO NONE))
	     ((EQUAL SLOTCON (CAR TEMPDL)) (RETURN NIL))
	     ((DVP (CAR TEMPDL)) (GO ELOOP))
	     ((EQ (CAR SLOTCON) (CAAR TEMPDL)) (GO FOUND))
	     (T (SETQ HOLDSLOT SLOTNO)))
  ELOOP(SETQ TEMPDL (CDR TEMPDL))
       (SETQ SLOTNO (SUB1 SLOTNO))
       (GO LOOP)
  FOUND(SETSLOT SLOTNO SLOTCON)
       (COND ((NULL (CDR SLOTCON))
	      (SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP)))))
       (OUTMOVEM ACNO SLOTNO)
       (RETURN NIL)
  NONE (COND (HOLDSLOT (SETQ SLOTNO HOLDSLOT) (GO FOUND)))
  MAKE (COND ((AND PROGSW (NOT (ASSOC (CAR SLOTCON) LOCVARS)))
	      (SETQ TEMPDL (PDLDEPTH))
	      (CLRPVARS)
	      (COND ((LESSP ACNO 1)
		     (SETQ ACNO	(PLUS ACNO
				      (DIFFERENCE TEMPDL
						  (PDLDEPTH))))))))
       (SLOTPUSH SLOTCON)
       (COND ((NULL (CDR SLOTCON))
	      (SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP)))))
       (OUTPUSH ACNO)
       (RETURN NIL)))
 
(DFUNC (CSFUN L AC)
 (PROG (Y)
       (COND ((AND (SETQ Y (ASSOC (CAR L) LDLST)) (NOT (ILOC Y AC)))
	      (LOADCARCDR L AC)))))
 
(DFUNC (CSTEP FUN AC ARGLOC)
       (PROG (TEM)
	     (COND ((NULL FUN) (RETURN (LIST ARGLOC)))
		   ((SETQ TEM (COPT FUN AC ARGLOC)) (RETURN (LIST TEM))))
	     (RETURN (CONS (CAR (SETQ TEM (GETPROP FUN (Q CARCDR))))
			   (CSTEP (CDR TEM) AC ARGLOC)))))
 
(DFUNC (DOP2 XPR VALAC EFFECTS)
       ((GETPROP (CAR XPR) (Q P2)) XPR VALAC EFFECTS))
 
 








(DFUNC (DVP X)
 (PROG (Y Z)
       (COND ((NULL X) (RETURN NIL)))
       (COND ((EQ (CAR X) (Q QUOTE)) (RETURN NIL)))
       (COND ((EQ (CDR X) (Q DUP)) (RETURN NIL)))
       (COND ((EQ (CDR X) (Q TAKEN)) (RETURN T)))
       (COND ((AND (SPECVARP (CAR X)) (NULL (CDR X))) (RETURN NIL)))
       (COND ((AND (SETQ Y (ASSOC (CAR X) LOCVARS))
		   (NULL (CDR X))
		   (LESSP P2CNT (CDR Y)))
	      (RETURN T)))
       (SETQ Z LDLST)
  LOOP (COND ((NULL Z)
	      (RETURN (COND ((SETQ Z (ASSOC (CAR X) VARLIST))
			     (DVP (CONS (CDR Z) (CDR X))))
			    (T NIL)))))
       (COND ((AND (EQ (CAAR Z) (CAR X))
		   (EQUAL (LOC X) (LOC (CAR Z))))
	      (RETURN T)))
       (SETQ Z (CDR Z))
       (GO LOOP)))
 
(DFUNC (EQUIVTAG PTAG)
 (PROG (LTAG)
       (COND ((SETQ LTAG (ASSOC PTAG GOLIST)) (RETURN (CDR LTAG))))
       (USERWARN PTAG UNDEFINED TAG)
       (RETURN EXIT)))
 
(DFUNC (EXITBUM SPECFLAG)
 (PROG (TEM1 TEM2)
       (COND ((NULL LASTOUT))
	     ((SETQ TEM1 (ASSOC	(CAAR LASTOUT)
				(Q ((CALL JCALL) (PUSHJ JRST)))))
	      (SETQ TEM2 (CAR LASTOUT))
	      (SETQ LASTOUT NIL)
	      (KILLPDL)
	      (OUTINST TEM2)
	      (COND ((NOT SPECFLAG)
		     (SETQ TEM2 (CAR LASTOUT))
		     (SETQ LASTOUT NIL)
		     (OUTINST (MCONS (CADR TEM1)
				     (SUBST 0 (Q P) (CADR TEM2))
				     (CDDR TEM2)))
		     (RETURN NIL)))))
       (KILLPDL)
       (COND (SPECFLAG (OUTINST (Q (JRST 0 SPECSTR))))
	     (T (OUTINST (Q (POPJ P)))))))
 








(DFUNC (FREEAC) (FREEAC1 VALUEAC))
 
(DFUNC (FREEAC1 BEST)
 (PROG (ACNO ACCS)
       (COND ((AND (NOT (NULL BEST)) (NOT (DVP (SLOTCONT BEST))))
	      (RETURN BEST)))
       (SETQ ACCS ACS)
       (SETQ ACNO 1)
  LOOP (COND ((NULL ACCS) (COND	((NULL BEST) (RETURN NIL))
				(T (CPUSH BEST) (RETURN BEST)))))
       (COND ((NOT (DVP (CAR ACCS))) (RETURN ACNO)))
       (SETQ ACCS (CDR ACCS))
       (SETQ ACNO (ADD1 ACNO))
       (GO LOOP)))
 
(DFUNC (FINDFREEAC) (FREEAC1 NIL))
 
(DFUNC (FREEZE VAR) (PROG NIL (FREEZE1 VAR ACS) (FREEZE1 VAR PDL)))
 
(DFUNC (FREEZE1 X Z)
       (PROG NIL
	LP   (COND ((NULL Z) (RETURN NIL))
		   ((EQ X (CAAR Z))
		    (COND ((OR (NULL (CDAR Z)) (EQ (CDAR Z) (Q DUP)))
			   (RPLACA Z (CONS X P2CNT))))))
	     (SETQ Z (CDR Z))
	     (GO LP)))
 
(DFUNC (GENCONST OP AC AD IN)					→***
       (COND ((NEEDS AD)
	      (OUTSTAT (LIST (Q MOVEI) (Q D) AD (Q S)))
	      (COND ((OR (NEQ OP 0) (NEQ AC 0) (NEQ IN 0))
		     (COMPERR BAD-S-REG-GENCONST)))
	      (Q D))
	     (T (LIST (Q C) OP AC AD IN))))
 
(DFUNC (GETSLOT NO)
 (COND ((NOT (NUMBERP NO)) (COMPERR NOTSLOT-GETSLOT))
       ((GREATERP NO NACS) (PRINTMSG NO) (COMPERR NOTAC-GETSLOT))
       ((GREATERP NO 0) (NTHCDR (SUB1 NO) ACS))
       ((GREATERP (ABS NO) (PDLDEPTH)) (PRINTMSG NO)
				       (COMPERR NOTONPDL-GETSLOT))
       ((NTHCDR (MINUS NO) PDL))))
 
 








(DFUNC (ILOC X AC)
 (PROG (CNTR BEST BESTNO SL SLOT CNT XCNT)
       (COND ((NULL AC) (GO LOOK)))
       (SETQ SLOT (SLOTCONT AC))
       (AND (EQ (CDR SLOT) (Q DUP)) (SETQ SLOT (LIST (CAR SLOT))))
       (COND ((EQUAL X SLOT) (RETURN AC)))
  LOOK (COND ((EQ (CAR X) (Q QUOTE)) (RETURN (LIST X))))
       (SETQ SL (SLOTLIST))
       (SETQ CNTR 1)
       (SETQ BESTNO (ADD1 P2CNT))
       (SETQ XCNT (COND ((NUMBERP (CDR X)) (CDR X)) (T P2CNT)))
  LOOP (COND ((NULL SL) (GO EXIT)))
       (SETQ SLOT (CAR SL))
       (COND ((AND SLOT (EQ (CAR SLOT) (CAR X))) (GO ISONE)))
  ELOOP(SETQ SL (CDR SL))
       (SETQ CNTR (ADD1 CNTR))
       (GO LOOP)
  EXIT (COND ((NOT (GREATERP BESTNO P2CNT)) (GO RETN)))
       (COND ((SPECIALP (CAR X))
	      (RETURN (LIST (QUOTE SPECIAL) (CAR X)))))
       (RETURN NIL)
 ISONE (COND ((EQ (CDR SLOT) (Q TAKEN))
	      (COND ((EQUAL X SLOT) (SETQ BEST CNTR) (GO RETN))
		    (T (GO ELOOP)))))
       (SETQ CNT (COND ((NUMBERP (CDR SLOT)) (CDR SLOT)) (T P2CNT)))
       (COND ((AND (NOT (LESSP CNT XCNT)) (LESSP CNT BESTNO))
	      (SETQ BESTNO CNT)
	      (SETQ BEST CNTR)))
       (GO ELOOP)
  RETN (RETURN (COND ((NOT (GREATERP BEST NACS)) BEST)
		     (T (PLUS (MINUS BEST) NACS 1))))))
 
(DFUNC (ILOC1 X AC)
 (PROG (Z)
       (COND ((SETQ Z (ILOC X AC)) (RETURN Z)))
       (COND ((MEMBER (CAR X) PROGVARS) (RETURN (Q ((QUOTE NIL))))))
       (COND ((SETQ Z (ASSOCR (CAR X) VARLIST))
	      (RETURN (ILOC1 (CONS (CAR Z) (CDR X)) AC))))
       (COND ((SETQ Z (ASSOC (CAR X) CCLST))
	      (RETURN (LOADCARCDR Z
				  (COND	((NULL AC) (FREEAC))
					(T AC))))))
       (PRINTMSG (LIST X))
       (COMPERR LOSTVAR-ILOC1)))
 
(DFUNC (INITZ X)
       (PROG NIL (SLOTPUSH (LIST X)) (OUTPUSH (Q ((QUOTE NIL))))))
 
 








(DFUNC (INTERNALLAMBDA XPR VALAC EFFECTS)
  (PROG (LAMXPR LAMARGS SF LAMVARS TL TEM)
	(SETQ LAMXPR (CAR XPR))
	(SETQ LAMVARS (CADR LAMXPR))
	(SETQ LAMARGS (REVERSE (COMPARGS (CDR XPR))))
	(COND ((NOT (EQUAL (LENGTH LAMVARS) (LENGTH LAMARGS)))
	       (USERERR ARGNOERR-INTERNALLAMBDA)))
      A (COND ((NULL LAMVARS) (GO B)))
	(SETQ TL (ILOC1 (CAR LAMARGS) (FREEAC)))
	(REMOVE (CAR LAMARGS))
	(COND ((SPECVARP (SETQ TEM (CAR LAMVARS)))
	       (SETQ SF T)
	       (COND ((OR (NOT (NUMBERP TL)) (LESSP TL 1Q))
		      (LOADARG (SETQ TL (FREEAC)) (CAR LAMARGS))))
	       (COND ((ASSOC TEM SPLDLST) (CLRSPVAR TEM) (REMSPVAR TEM))))
	      ((OR (NOT (NUMBERP TL)) (DVP (SETQ TEM (SLOTCONT TL))))
	       (SLOTPUSH TEM)
	       (OUTPUSH TL)
	       (SETQ TL 0Q)))
	(SETSLOT TL (CONS (CAR LAMVARS) (Q TAKEN)))
	(SETQ LAMARGS (CDR LAMARGS))
	(SETQ LAMVARS (CDR LAMVARS))
	(GO A)
      B (COND (SF (OUTINST (Q (JSP 6Q SPECBIND)))))
	(SETQ LAMVARS (CADR LAMXPR))
      C (COND ((NULL LAMVARS) (GO D)))
	(SETQ TL (ILOC (CONS (CAR LAMVARS) (Q TAKEN)) NIL))
	(COND ((SPECVARP (CAR LAMVARS))
	       (FREEZE (CAR LAMVARS))
	       (OUTINST (LIST 0Q TL (LIST (Q SPECIAL) (CAR LAMVARS)) (Q S)))))
	(RPLACD (SLOTCONT TL) NIL)
	(SETQ LAMVARS (CDR LAMVARS))
	(GO C)
      D (SETQ LAMVARS (CADR LAMXPR))
	(COND (EFFECTS (SETQ TEM (COMPE (CADDR LAMXPR) VALAC)))
	      (T (SETQ TEM (COMP (CADDR LAMXPR) VALAC))
		 (COND ((EQ (CAR TEM) @QUOTE) (GO DD)) (T (SETQ TL (LOC TEM))))
		 (COND ((NOT (NUMBERP TL))
			(AND (EQ (CAR TL) @SPECIAL)
			     (NOT (MEMB (CADR TL) LAMVARS))
			     (GO DD))
			(LOADARG VALAC TEM)
			(SETQ TL VALAC)))
		 (COND ((MEMB (CAR (SLOTCONT TL)) LAMVARS)
			(REMOVE TEM)
			(SETQ TEM (MARKVAL TL EFFECTS))))))
     DD (COND (SF (OUTINST (Q (PUSHJ P SPECSTR)))))
	(INCR P2CNT)
      E (COND ((NULL LAMVARS) (RETURN TEM)) (T (FREEZE (CAR LAMVARS))))
	(SETQ LAMVARS (CDR LAMVARS))
	(GO E)))
 








(DFUNC (KILLPDL) (RESTORE NIL))
 
(DFUNC (LAMBDABIND VARS) (BINDVARS VARS T))
 
(DFUNC (LISTNILS NUMBER)
       (PROG (LIST)
	LOOP (COND ((ZEROP NUMBER) (RETURN LIST)))
	     (SETQ LIST (CONS NIL LIST))
	     (SETQ NUMBER (SUB1 NUMBER))
	     (GO LOOP)))
 
(DFUNC (LOADARG ACNO VAR)
 (PROG (DATAORG OLDACC DATACONT DAC DOD)
       (REMOVE VAR)
       (SETQ DATAORG (ILOC1 VAR ACNO))
       (SETQ OLDACC (SLOTCONT ACNO))
       (SETQ DATACONT (COND ((NUMBERP DATAORG) (SLOTCONT DATAORG))))
       (SETQ DAC (DVP OLDACC))
       (SETQ DOD (DVP DATACONT))
       (COND ((EQ ACNO DATAORG)	(COND (DAC (CPUSH ACNO)))
				(RETURN NIL)))
       (COND ((AND (EQ DATAORG 0)
		   (NOT DOD)
		   (NOT DAC)
		   (GREATERP (PDLDEPTH) MINDEPTH))
	      (GO POP)))
       (COND ((AND (NOT DOD)
		   (NOT (NULL OLDACC))
		   (NUMBERP DATAORG)
		   (LESSP DATAORG ACNO))
	      (GO EXCH)))
       (COND ((NOT DAC) (GO FREE)))
       (GO PUSH)
  EXCH (SETSLOT DATAORG OLDACC)
       (SETSLOT ACNO DATACONT)
       (OUT1 (Q EXCH) ACNO DATAORG)
       (RETURN NIL)
  PUSH (CPUSH ACNO)
       (SETQ DATAORG (LOC VAR))
  FREE (COND ((NOT (NUMBERP DATAORG)) (GO MOVE)))
       (SETSLOT	ACNO
		(COND ((NULL (CDR DATACONT))
		       (CONS (CAR DATACONT) (Q DUP)))
		      (T DATACONT)))
       (OUTMOVE ACNO DATAORG)
       (RETURN NIL)
  POP  (SETSLOT ACNO DATACONT)
       (OUTPOP ACNO)
       (RETURN NIL)
  MOVE (SETSLOT	ACNO
		(COND ((EQ (CAAR DATAORG) (Q QUOTE)) (CAR DATAORG))
		      (T (LIST (CAR VAR)))))
       (OUTMOVE ACNO DATAORG)
       (RETURN NIL)))








(DFUNC (LOADCARCDR ITEM AC)
 (PROG (ARG PATH ORIG)
       (COND ((EQ (ILOC1 (SETQ ARG (CDDR ITEM)) AC) AC)
	      (REMOVE ARG)))
       (SETQ PATH (CSTEP (CADR ITEM) AC ARG))
       (COND ((NULL (CDR PATH))
	      (SETQ VARLIST (CONS (CONS (CAR (CAR PATH)) (CAR ITEM))
				  VARLIST))
	      (REMOVE ARG)
	      (RETURN (LOC (CAR PATH)))))
       (SETQ PATH (REVERSE PATH))
       (CPUSH AC)
       (SETQ ORIG (LOC (CAR PATH)))
       (SETQ PATH (CDR PATH))
       (REMOVE ARG)
  L1   (COND ((NULL PATH) (GO RET)))
       (COND ((NULL (CDR PATH)) (GO L2)))
       (COND ((AND (EQ AC VALUEAC) (EQ ORIG VALUEAC))
	      (OUTCALL 1
		       (READLIST (CONS (Q C)
				       (REVERSE (CONS (Q R) PATH)))))
	      (GO RET)))
  L2   (OUT1 (CADR (ASSOC (CAR PATH) (Q ((A HLRZ@) (D HRRZ@)))))
	     AC
	     ORIG)
       (SETQ PATH (CDR PATH))
       (SETQ ORIG AC)
       (GO L1)
  RET  (SETSLOT AC (LIST (CAR ITEM)))
       (RETURN AC)))
 
(DFUNC (LOADCOMP XPR AC) (LOADARG AC (COMP XPR AC)))
 
(DFUNC (LOADSUBRARGS ARGS)
       (PROG (ARGNO)
	     (SETQ ARGNO (LENGTH ARGS))
	LOOP (COND ((NULL ARGS) (RETURN NIL)))
	     (LOADARG ARGNO (CAR ARGS))
	     (SETQ ARGS (CDR ARGS))
	     (SETQ ARGNO (SUB1 ARGNO))
	     (GO LOOP)))
 
 








(DFUNC (LOC X) (ILOC1 X NIL))
 
(DFUNC (MARKVAL LOCATION EFFECTS)
       (PROG (VAR GVAL)
	     (COND ((NULL LOCATION) (COMPERR NULLLOC-MARKVAL)))
	     (SETQ GVAL (GENVAL))
	     (SETQ VAR (CAR (SETSLOT LOCATION (LIST GVAL))))
	     (COND ((NOT EFFECTS) (SETQ LDLST (CONS VAR LDLST))))
	     (RETURN VAR)))
 
(DFUNC (NONSPECVARS VRS)
       (PROG (ANS)
	LOOP (COND ((NULL VRS) (RETURN ANS))
		   ((SPECVARP (CAR VRS)))
		   (T (SETQ ANS (CONS (CAR VRS) ANS))))
	     (SETQ VRS (CDR VRS))
	     (GO LOOP)))
 
(DFUNC (OUT1 OP AC AD) (OUTINST (TRANSOUT OP AC AD)))
 
(DFUNC (OUTCALL NUM FUN)					→***
       (COND ((GET FUN (Q NOCALL)) (OUT1 (Q PUSHJ) (Q P) FUN))
	     (T (OUTFUNCALL (Q CALL) NUM FUN))))
 
(DFUNC (OUTCALLF AC AD) (OUT1 (Q CALLF@) AC AD))
 
(DFUNC (OUTCJMP FLAG AC ADRESS)
       (OUTJMP (COND (FLAG (Q JUMPN)) (T (Q JUMPE))) AC ADRESS))
 
(DFUNC (OUTENDTAG X)
       (COND ((USEDTAGP X) (CLEARITALL) (RST X) (OUTTAG X))))
 
(DFUNC (OUTFUNCALL TYPE NUM FUN)
       (OUTINST (LIST TYPE NUM (LIST (Q E) FUN) (Q S))))	→***
 
(DFUNC (OUTGOTAB X)
 (PROG (ETAG)
       (SETQ ETAG (GENTAG))
       (PUTPROP ETAG (TOPCOPY PDL) (Q LEVEL))
       (COND ((NOT (EQ (CAAR LASTOUT) (Q JRST))) (OUTJRST ETAG)))
       (OUTTAG (CAR X))
  LOOP (SETQ X (CDR X))
       (COND ((NULL X) (OUTINST (Q (PUSHJ P *UDT)))
		       (OUTTAG ETAG)
		       (RETURN NIL)))
       (OUTINST (LIST (Q CAIN) GOTABAC (LIST (Q QUOTE) (CAAR X)) (Q S))) →***
       (OUTJRST (CDAR X))
       (GO LOOP)))
 
(DFUNC (OUTJCALL NUM FUN)					→***
       (COND ((GET FUN (Q NOCALL)) (OUT1 (Q JRST) 0 FUN))
	     (T (OUTFUNCALL (Q JCALL) NUM FUN))))








(DFUNC (OUTJMP OP AC ADR)
       (PROG NIL
	     (CLEAR1BOTH)
	     (SAVEACS)
	     (RST ADR)
	     (PUTPROP ADR T (Q USED))
	     (OUTINST (LIST OP AC ADR))))
 
(DFUNC (OUTJRST ADR) (OUTJMP (Q JRST) 0 ADR))
 
(DFUNC (OUTMOVE AC MEM) (OUT1 (Q MOVE) AC MEM))
 
(DFUNC (OUTMOVEM AC MEM)
       (COND ((AND (EQ MEM 0)
		   LASTOUT
		   (EQ (CAAR LASTOUT) (Q PUSH))
		   (EQ (CADAR LASTOUT) (Q P)))
	      (SETQ LASTOUT NIL)
	      (OUT1 (Q PUSH) (Q P) AC))
	     (T (OUT1 (Q MOVEM) AC MEM))))
 
(DFUNC (OUTPOP L)
       (PROG (L1)
	     (SLOTPOP)
	     (COND ((AND LASTOUT
			 (EQ (CAAR LASTOUT) (Q PUSH))
			 (EQ (CADAR LASTOUT) (Q P)))
		    (SETQ L1 (CADDAR LASTOUT))
		    (COND ((EQUAL L1 L)
			   (RETURN (SETQ LASTOUT NIL)))
			  ((ACNUMP L)
			   (SETQ LASTOUT NIL)
			   (RETURN (OUTMOVE L L1))))))
	     (RETURN (OUT1 (Q POP) (Q P) L))))
 
(DFUNC (OUTPUSH L)
       (COND ((AND LASTOUT
		   (EQ (CAAR LASTOUT) (Q POP))
		   (ACNUMP L)
		   (EQUAL (CDDAR LASTOUT) (LIST (Q P) L)))
	      (SETQ LASTOUT NIL)
	      (OUTMOVE L 0))
	     (T (OUT1 (Q PUSH) (Q P) L))))
 
(DFUNC (OUTPUTSTAT ST)
       (PROG (ADD)
	     (COND ((ATOM ST) (GO PRINT)))
	     (COND ((EQ (CAR ST) (Q LAP)) (GO PRINT)))
	     (SETQ CODESIZE (ADD1 CODESIZE))
	     (SETQ ADD (CADDR ST))
	     (COND ((AND (NOT (ATOM ADD)) (EQ (CAR ADD) (Q C)))
		    (SETQ CONSTSIZE (ADD1 CONSTSIZE))))
	PRINT(PRINTSTAT ST)))
 








(DFUNC (OUTSTAT ST)
       (PROG NIL
	     (COND ((NULL LASTOUT) (GO SETIT)))
	     (OUTPUTSTAT (CAR LASTOUT))
	     (MAPC (FUNCTION (LAMBDA (X) (TERPRI) (TAB 22) (PRIN1 X)))
		   (CDR LASTOUT))
	SETIT(SETQ LASTOUT (CONS ST (LAPNOTES)))
	     (RETURN NIL)))
 
(DFUNC (P2*EVAL XPR VALAC EFFECTS)
       (PROG (ARG TEM)
	     (SETQ ARG (CADR XPR))
	     (COND ((AND (EQ (CAR ARG) (Q CONS))
			 (EQ (CAADR ARG) (Q QUOTE))
			 (GETL (SETQ TEM (CADADR ARG))
			       (Q (FEXPR FSUBR *FSUBR))))
		    (GO NOCONS)))
	     (RETURN (CALLSUBR XPR VALAC EFFECTS))
      NOCONS (LOADCOMP (CADDR ARG) FARGAC)
	     (CLEAR2BOTH)
	     (PROTECTACS TEM)
	     (OUTCALL 17 TEM)
	     (RETURN (MARKVAL VALUEAC EFFECTS))))
 
(DFUNC (P2ARG XPR VALAC EFFECTS)
       (PROG (ARG)
	     (COND ((NOT INLSUBR) (USERERR NOTINLSUBR-P2ARG)))
	     (SETQ ARG (COMP (CADR XPR) VALAC))
	     (COND ((EQ (CAR ARG) (Q QUOTE))
		    (CPUSH VALAC)
		    (OUTMOVE VALAC (MINUS (ADD1 (PDLDEPTH))))
		    (OUTINST (LIST (Q HRRZ) VALAC (CADR ARG) VALAC))
		    (RETURN (MARKVAL VALAC EFFECTS))))
	     (LOADARG VALAC ARG)
	     (OUT1 (Q ADD) VALAC (MINUS (ADD1 (PDLDEPTH))))
	     (OUTINST (LIST (Q HRRZ) VALAC (MINUS INUM0) VALAC))
	     (RETURN (MARKVAL VALAC EFFECTS))))
 
(DFUNC (P2CARCDR XPR VALAC EFFECTS)
 (PROG (TEM)
       (COND ((NOT (EQ (LENGTH (CDR XPR)) 1))
	      (USERERR ARGNOERR-P2CARCDR)))
       (COND (EFFECTS (RETURN (COMPE (CADR XPR) VALAC))))
       (SETQ XPR (CONS (SETQ TEM (GENSYM))
		       (CONS (CAR XPR) (COMP (CADR XPR) VALAC))))
       (SETQ CCLST (CONS XPR CCLST))
       (SETQ TEM (CONS TEM P2CNT))
       (SETQ LDLST (CONS TEM LDLST))
       (RETURN TEM)))
 








(DFUNC (P2COND XPR VALAC EFFECTS)
  (PROG (LDL VARLOC LOCCONT)
	(SETQ LDL LDLST)
   LOOP	(COND ((NULL LDL) (GO OK)) ((ASSOC (CAAR LDL) LOCVARS) (GO ISVAR)))
  ELOOP	(SETQ LDL (CDR LDL))
	(GO LOOP)
  ISVAR	(COND ((NOT (NUMBERP (SETQ VARLOC (LOC (CAR LDL))))))
	      ((NOT (DVP (SETQ LOCCONT (SLOTCONT VARLOC))))
	       (SETSLOT VARLOC (CONS (CAAR LDL) P2CNT))
	       (GO ELOOP))
	      ((NUMBERP (CDR LOCCONT)) (GO ELOOP)))
	(SLOTPUSH (CONS (CAAR LDL) P2CNT))
	(OUTPUSH VARLOC)
	(GO ELOOP)
     OK	(CLEAR1)
	(INCR P2CNT)
	(P2COND1 (CDR XPR) VALAC EFFECTS NIL NIL)
	(INCR P2CNT)
	(INCR P2CNT)
	(CPUSH VALAC)
	(RETURN (MARKVAL VALAC EFFECTS))))
 
(DFUNC (P2COND1 EXP VALAC EFFECTS BOOLFLG BOOLTAG)
  (PROG	(CTAG RSL MINDEPTH CONDEXIT PAIREXIT H1 H2 RETNIL IRSSL ACNIL PAIR ATAG
	      REST)
	(SETQ CONDEXIT (GENTAG))
	(SETQ IRSSL (TOPCOPY PDL))
	(SETQ MINDEPTH (PDLDEPTH))
	(PUTPROP CONDEXIT IRSSL (Q LEVEL))
   LOOP	(SETQ RSL NIL)
	(COND ((NULL EXP)
	       (COND (RETNIL (LOADARG VALAC (Q (QUOTE NIL)))))
	       (OUTENDTAG CONDEXIT)
	       (COND ((OR (USEDTAGP PAIREXIT) BOOLTAG) (CLEARITALL)))
	       (RESTORE IRSSL)
	       (RETURN NIL)))
	(SETQ PAIR (CAR EXP))
	(COND ((NULL (CDR PAIR))
	       (COND ((NULL (CDR EXP))
		      (COND (EFFECTS (COMPE (CAR PAIR) VALAC))
			    (BOOLTAG (BOOLEXPR (CAR PAIR)
					       VALAC
					       BOOLTAG
					       BOOLFLG
					       MINDEPTH))
			    (T (LOADCOMP (CAR PAIR) VALAC))))
		     ((OR EFFECTS (AND BOOLTAG (NULL BOOLFLG)))
		      (BOOLEXPR (CAR PAIR) VALAC CONDEXIT T MINDEPTH))
		     (BOOLTAG (BOOLEXPR (CAR PAIR) VALAC BOOLTAG T MINDEPTH))
		     (T (LOADCOMP (CAR PAIR) VALAC) (OUTCJMP T VALAC CONDEXIT)))
	       (RESTORE IRSSL)
	       (GO NONIL)))
	(COND (BOOLTAG (GO L2)))
	(COND ((AND (EQUAL (CDR PAIR) (Q ((QUOTE NIL))))
		    (EQ (CAAR PAIR) (Q NULL))
		    (OR (ATOM (CADAR PAIR))
			(NOT (HASPROP (CAADAR PAIR) (Q BOOL)))))
	       (LOADCOMP (CADAR PAIR) VALAC)
	       (OUTCJMP NIL VALAC CONDEXIT)
	       (SETQ RETNIL T)
	       (GO ELOOP)))
	(COND ((OR LDLST (NOT (NULL (CDDR PAIR)))) (GO L2)))
	(COND ((AND (EQ (CAADR PAIR) (Q GO)) (ATOM (SETQ ATAG (CADADR PAIR))))
	       (BOOLEXPR (CAR PAIR) VALAC (EQUIVTAG ATAG) T MINDEPTH)
	       (GO NONIL)))
	(COND ((EQUAL (CADR PAIR) (Q (RETURN (QUOTE NIL))))
	       (BOOLEXPR (CAR PAIR) VALAC EXITN T MINDEPTH)
	       (GO NONIL)))
     L2	(SETQ PAIREXIT (SETQ CTAG (GENTAG)))
	(PUTPROP PAIREXIT IRSSL (Q LEVEL))
	(SETQ RSL NIL)
	(BOOLEXPR (CAR PAIR)
		  VALAC
		  (COND ((AND BOOLTAG (NULL (CDR EXP)) (NULL BOOLFLG)) BOOLTAG)
			(T PAIREXIT))
		  NIL
		  MINDEPTH)
	(SETQ H2
	      (COND ((NOT (ATOM RSL)) RSL)
		    (T (LIST (TOPCOPY ACS) (TOPCOPY PDL) (PDLDEPTH)))))
	(SETQ H1 (LIST (TOPCOPY SPLDLST) (TOPCOPY CCLST)))
	(SETQ REST (CDR PAIR))
    LP1	(COND ((NULL (CDR REST)) (GO L1)))
	(COMPE (CAR REST) VALAC)
	(SETQ REST (CDR REST))
	(GO LP1)
     L1	(COND (EFFECTS (COMPE (CAR REST) VALAC))
	      (BOOLTAG (BOOLEXPR (CAR REST) VALAC BOOLTAG BOOLFLG MINDEPTH))
	      (T (LOADCOMP (CAR REST) VALAC)))
	(SAVEACS)
	(SETQ SPLDLST (CAR H1))
	(SETQ CCLST (CADR H1))
	(SETQ H1 ACS)
	(SETQ ACS (CAR H2))
	(SETQ ACNIL (EQUAL (SLOTCONT VALAC) (Q (QUOTE NIL))))
	(SETQ ACS H1)
	(SETQ RETNIL NIL)
	(COND ((NOT (MEMQ (CAAR REST) (Q (GO RETURN))))
	       (COND ((OR (NOT (NULL (CDR EXP)))
			  (AND (NOT EFFECTS)
			       (NOT BOOLTAG)
			       (NOT ACNIL)
			       (SETQ RETNIL (USEDTAGP PAIREXIT))))
		      (OUTJRST CONDEXIT))
		     (T (RESTORE IRSSL)))))
	(SETQ ACS (CAR H2))
	(SETQ PDL (CADR H2))
	(SETQ PDLDEPTH (CADDR H2))
	(COND ((USEDTAGP PAIREXIT) (OUTTAG PAIREXIT)))
	(GO ELOOP)
  NONIL	(SETQ RETNIL NIL)
  ELOOP	(SETQ EXP (CDR EXP))
	(GO LOOP)))








(DFUNC (P2ELSE XPR VALAC EFFECTS) (COMPERR SOMETHINGELSE-P2ELSE))
 
(DFUNC (P2EQ XPR VALAC EFFECTS)
       (PROG NIL
	     (COND (EFFECTS (COMPE (CADR XPR) VALAC)
			    (COMPE (CADDR XPR) VALAC)
			    (RETURN NIL)))
	     (BOOLEQ1 (CDR XPR) VALAC NIL NIL)
	     (RETURN (BOOLVALUE VALAC EFFECTS NIL))))
 
(DFUNC (P2GO XPR VALAC EFFECTS)
 (PROG (TAG)
       (SETQ TAG (CADR XPR))
       (SAVEACS)
       (CLRPVARS)
       (COND ((ATOM TAG) (OUTJRST (EQUIVTAG TAG)))
	     (T (LOADARG GOTABAC (COMP TAG VALAC)) (OUTJRST VGO)))
       (RETURN (MARKVAL VALUEAC EFFECTS))))
 
(DFUNC (P2NULL XPR VALAC EFFECTS)
       (PROG (CTAG RSL G)
	     (CLEAR2BOTH)
	     (PUTPROP (SETQ G (GENTAG)) T (Q SET))
	     (BOOLEXPR XPR VALAC G T MINDEPTH)
	     (RETURN (BOOLVALUE VALAC EFFECTS G))))
 








(DFUNC (P2PROG XPR VALAC EFFECTS)
       (PROG (PSFLG)
	     (SETQ PSFLG (PROGBIND (CADDR XPR)))
	     (SETQ PRGSPFLG NIL)
	     (CLEAR1)
	     (P2PROG1 XPR VALAC EFFECTS MINDEPTH)
	     (COND (PSFLG (OUTINST (Q (PUSHJ P SPECSTR)))))
	     (CPUSH VALAC)
	     (RETURN (MARKVAL VALAC EFFECTS))))
 
(DFUNC (P2PROG1 XPR VALAC EFFECTS MINDEPTH)
 (PROG (GOLIST EXIT EXITN PVR PRSSL PROGSW VGO)
       (INCR P2CNT)
       (SETQ PROGSW T)
       (SETQ PVR (COND (EFFECTS NIL) (T VALAC)))
       (SETQ EXIT (GENTAG))
       (SETQ EXITN (GENTAG))
       (SETQ VGO (GENTAG))
       (SETQ GOLIST (CONS (CONS NIL EXIT)
			  (CONS	(CONS NIL EXITN)
				(CONS (CONS NIL VGO) (CADR XPR)))))
       (SETQ PROGVARS (NONSPECVARS (CADDR XPR)))
       (SETQ XPR (CDDDR XPR))
  LOOP (COND ((NULL XPR) (GO EXITN)))
       (INCR P2CNT)
       (COND ((NOT PROGSW) (RESTORE PRSSL)))
       (COND ((TAGP (CAR XPR)) (PROGTAG (CAR XPR)))
	     ((AND (NULL (CDR XPR)) (EQ (CAAR XPR) (Q RETURN)))
	      (COND ((EQUAL (CDAR XPR) (Q ((QUOTE NIL)))) (GO EXITN))
		    (EFFECTS (COMPE (CADAR XPR) VALAC))
		    (T (LOADCOMP (CADAR XPR) VALAC)))
	      (COND ((USEDTAGP EXITN) (OUTJRST EXIT) (GO EXITN))
		    (T (GO EXIT))))
	     (T (COMPE (CAR XPR) VALAC)))
       (SETQ XPR (CDR XPR))
       (GO LOOP)
  EXITN(OUTENDTAG EXITN)
       (COND ((AND (NOT EFFECTS) (NOT (EQ (CAAR LASTOUT) (Q JRST))))
	      (LOADARG PVR (Q (QUOTE NIL)))))
  EXIT (OUTENDTAG EXIT)
       (INCR P2CNT)
       (INCR P2CNT)
       (COND ((USEDTAGP VGO) (OUTGOTAB (CONS VGO (CDDDR GOLIST)))))
       (RETURN NIL)))
 
 








(DFUNC (P2PROG2 XPR VALAC EFFECTS)
 (PROG (ARGS ARG2)
       (SETQ ARGS (CDR XPR))
       (COND ((LESSP (LENGTH ARGS) 2) (USERERR TOFEWARGS-P2PROG2)))
       (COMPE (CAR ARGS) VALAC)
       (SETQ ARG2 (COND	((NOT EFFECTS) (COMP (CADR ARGS) VALAC))
			(T (COMPE (CADR ARGS) VALAC))))
       (SETQ ARGS (CDDR ARGS))
  LOOP (COND ((NULL ARGS) (RETURN ARG2)))
       (COMPE (CAR ARGS) VALAC)
       (SETQ ARGS (CDR ARGS))
       (GO LOOP)))
 
(DFUNC (P2QUOTE XPR VALAC EFFECTS) XPR)
 
(DFUNC (P2RETURN XPR VALAC EFFECTS)
       (PROG (VAL)
	     (SETQ VAL (CADR XPR))
	     (SAVEACS)
	     (CLRPVARS)
	     (COND ((EQUAL VAL (Q (QUOTE NIL))) (OUTJRST EXITN) (GO DONE))
		   ((NULL PVR) (COMPE VAL VALAC))
		   (T (LOADCOMP VAL PVR)))
	     (OUTJRST EXIT)
	DONE (RETURN (MARKVAL VALAC EFFECTS))))
 
(DFUNC (P2RPLAC XPR VALAC EFFECTS)
       (PROG (ARG1 ARG2)
	     (SETQ ARG1 (COMP (CADR XPR) (FREEAC)))
	     (SETQ ARG2 (COMP (CADDR XPR) (FREEAC)))
	     (ILOC1 ARG1 VALAC)
	     (LOC ARG2)
	     (REMOVS ARG1)
	     (REMOVS ARG2)
	     (CLEAR2BOTH)
	     (COND ((EQUAL ARG2 (Q (QUOTE NIL)))
		    (OUT1 (CADR	(ASSOC (CAR XPR)
				       (Q ((RPLACA HRRZS@)
					   (RPLACD HLLZS@)))))
			  0
			  (LOC ARG1)))
		   (T (OUT1 (CADR (ASSOC (CAR XPR)
					 (Q ((RPLACA HRLM@)
					     (RPLACD HRRM@)))))
			    (PUTINAC ARG2 (FREEAC))
			    (LOC ARG1))))
	     (REMOVE ARG2)
	     (RETURN ARG1)))
 
 








(DFUNC (P2SETARG XPR VALAC EFFECTS)
  (PROG (ARG AC)
	(COND ((NOT INLSUBR) (USERERR NOTINLSUBR-P2SETARG)))
	(SETQ ARG (COMP (CADDR XPR) VALAC))
	(CLEARAC (SETQ AC (COND ((EQ VALAC 5Q) 4Q) (T 5Q))))
	(COND ((EQ (CAADR XPR) (Q QUOTE))
	       (LOADARG VALAC ARG)
	       (OUT1 (Q MOVE) AC (MINUS (ADD1 (PDLDEPTH))))
	       (OUTINST (LIST (Q HRRM) VALAC (CADADR XPR) AC))
	       (RETURN ARG)))
	(LOADCOMP (CADR XPR) AC)
	(LOADARG VALAC ARG)
	(OUT1 (Q ADD) AC (MINUS (ADD1 (PDLDEPTH))))
	(OUTINST (LIST (Q HRRM) VALAC (MINUS INUM0) AC))
	(RETURN ARG)))








(DFUNC (P2SETQ XPR VALAC EFFECTS)
 (PROG (NVAR VALLOC HOME VAR VAL TEM)
       (SETQ VAR (CAR (CDR XPR)))
       (SETQ VAL (COMP (CADR (CDR XPR)) VALAC))
       (ILOC1 VAL VALAC)
       (COND ((ASSOC VAR SPLDLST) (CLRSPVAR VAR) (REMSPVAR VAR))
	     (T (SETQ PROGVARS (DREMOVE VAR PROGVARS))))
       (REMOVE VAL)
       (FREEZE VAR)
       (SETQ VALLOC (LOC VAL))
       (SETQ HOME (COND	((SPECVARP VAR) T)
			((NOT (ILOC (SETQ NVAR (CONS VAR P2CNT)) VALAC))
			 NIL)
			(T (NOT (DVP (SLOTCONT (LOC NVAR)))))))
       (INCR P2CNT)
       (COND ((AND EFFECTS (NOT HOME))
	      (COND ((AND (NUMBERP VALLOC)
			  (NOT (DVP (SLOTCONT VALLOC))))
		     (SETSLOT VALLOC (LIST VAR))
		     (GO EXIT))
		    (T (SLOTPUSH (LIST VAR))
		       (OUTPUSH VALLOC)
		       (GO EXIT)))))
       (COND ((AND HOME (EQUAL VAL (Q (QUOTE NIL))))
	      (SETQ TEM T)
	      (OUT1 (COND ((OR EFFECTS (DVP (SLOTCONT VALAC)))
			   (SETQ TEM NIL)
			   (Q CLEARM))
			  (T (Q CLEARB)))
		    VALAC
		    (SETQ VAL (COND ((SPECVARP VAR)
				     (LIST (Q SPECIAL) VAR))
				    (T (ILOC (CONS VAR (SUB1 P2CNT))
					     VALAC)))))
	      (COND ((NUMBERP VAL) (SETSLOT VAL (LIST VAR))))
	      (COND (TEM (SETSLOT VALAC
				  (CONS	VAR
					(COND ((NUMBERP VAL) (Q DUP))
					      (T NIL))))))
	      (GO EXIT)))
       (COND ((OR (NOT (NUMBERP VALLOC))
		  (LESSP VALLOC 0)
		  (DVP (SLOTCONT VALLOC)))
	      (LOADARG VALAC VAL)
	      (SETQ VALLOC VALAC)))
       (SETSLOT VALLOC (LIST VAR))
       (COND ((SPECVARP VAR)
	      (COND ((ZEROP VALLOC) (OUTPOP (LIST (Q SPECIAL) VAR)))
		    (T (OUTMOVEM VALLOC (LIST (Q SPECIAL) VAR))))))
  EXIT (RETURN (COMP VAR VALAC))))
 
 








(DFUNC (P2STORE XPR VALAC EFFECTS)
       (PROG (TEM)
	     (LOC (SETQ TEM (COMP (CADDR XPR) VALAC)))
	     (COMPE (CADR XPR) VALAC)
	     (LOADARG ARRAYAC TEM)
	     (OUTINST (Q (PUSHJ P NSTR)))
	     (RETURN TEM)))
 
(DFUNC (PASS2 X)
 (PROG (ACS PDL PDLDEPTH MINDEPTH LDLST SPLDLST SPECFLAG PRGSPFLG
	CCLST VARLIST PROGVARS PROGSW GOLIST)
       (SETQ P2CNT 1)
       (SETQ ACS (LISTNILS NACS))
       (SETQ ALLACS (SUB1 (LSH 1 NACS)))
       (SETQ PDL NIL)
       (SETQ PDLDEPTH (LENGTH PDL))
       (SETQ MINDEPTH (PDLDEPTH))
       (SETQ SPECFLAG (LAMBDABIND (CADR X)))
       (COND ((NOT (EQ (CAADDR X) (Q PROG))) (SETQ PRGSPFLG NIL)))
       (LOADCOMP (CADDR X) VALUEAC)
       (EXITBUM SPECFLAG)
       (OUTINST (OUTINST NIL))
       (COND (LDLST (COMPERR LDLSTLEFT-PASS2)))
       (RETURN NIL)))
 
(DFUNC (PROGBIND VARS) (BINDVARS VARS NIL))
 
(DFUNC (PROGTAG TAG)
       (PROG NIL
	     (CLEAR2BOTH)
	     (CLEARACS)
	     (CLRPVARS)
	     (RESTORE PRSSL)
	     (OUTTAG (EQUIVTAG TAG))))
 
(DFUNC (PROTECTACS X)
 (PROG (WHICHACS ACNO)
       (SETQ WHICHACS (ACEFFECTS X))
       (SETQ ACNO 0)
  LOOP (SETQ ACNO (ADD1 ACNO))
       (COND ((ZEROP WHICHACS) (RETURN NIL))
	     ((NOT (ZEROP (BOOLE 1 1 WHICHACS))) (CLEARAC ACNO)))
       (SETQ WHICHACS (LSH WHICHACS -1))
       (GO LOOP)))
 
 








(DFUNC (PUTINAC X AC)
       (PROG (Z)
	     (SETQ Z (LOC X))
	     (COND ((NOT (ACNUMP Z)) (LOADARG (SETQ Z AC) X)))
	     (REMOVE X)
	     (CPUSH Z)
	     (RETURN Z)))
 
(DFUNC (REMOVE DATA)
       (PROG NIL (REMLST DATA (Q LDLST)) (REMLST DATA (Q SPLDLST))))
 
(DFUNC (REMLST DATA LST)
       (PROG (TEM)
	     (SETQ TEM (GETPROP LST (Q VALUE)))
	LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
	     (COND ((EQUAL (CADR TEM) DATA) (RPLACD TEM (CDDR TEM)))
		   (T (SETQ TEM (CDR TEM))))
	     (GO LOOP)))
 
(DFUNC (REMOVS DATA) (REMLST DATA (Q SPLDLST)))
 
(DFUNC (REMSPVAR SPV)
       (PROG (SPL)
	     (SETQ SPL (GETPROP (Q SPLDLST) (Q VALUE)))
	BACK (COND ((NULL (CDR SPL)) (RETURN NIL)))
	     (COND ((EQ SPV (CAADR SPL)) (RPLACD SPL (CDDR SPL)))
		   (T (SETQ SPL (CDR SPL))))
	     (GO BACK)))
 
 








(DFUNC (RESTORE OLDPDL)
 (PROG (C V R TEM OLDDEPTH DEPTHDIF)
       (SETQ OLDDEPTH (LENGTH OLDPDL))
       (COND ((GREATERP OLDDEPTH (PDLDEPTH))
	      (PRINTMSG (LIST OLDPDL PDL))
	      (COMPERR PDLSHORT-RESTORE)))
  A1   (SETQ C 0)
  A    (COND ((EQUAL OLDDEPTH (PDLDEPTH)) (RETURN (SHRINKPDL C)))
	     ((DVP (SETQ R (CAR PDL))) (GO CPP)))
       (SETQ C (ADD1 C))
       (SLOTPOP)
       (GO A)
  CPP  (SHRINKPDL C)
  CPP1 (SETQ V OLDPDL)
       (SETQ C 0)
       (SETQ DEPTHDIF (*DIF (PDLDEPTH) OLDDEPTH))
  CPP3 (COND ((NULL V) (SETQ V (FINDFREEAC))
		       (COND ((NULL V) (COMPERR NOAC-RESTORE)))
		       (SETSLOT V R)
		       (OUTPOP V)
		       (GO A1))
	     ((AND (CAR V)
		   (EQ (CAAR V) (CAR R))
		   (NOT	(DVP (SLOTCONT (SETQ TEM
					(MINUS (PLUS C
						     DEPTHDIF)))))))
	      (GO CPP2)))
       (SETQ C (ADD1 C))
       (SETQ V (CDR V))
       (GO CPP3)
  CPP2 (SETSLOT TEM R)
       (OUTPOP TEM)
       (GO A1)))
 
(DFUNC (RSLSET X)
 (COND ((EQ X CTAG)
	(SETQ RSL (COND	((AND RSL
			      (NOT (AND	(EQUAL (CAR RSL) ACS)
					(EQUAL (CADR RSL) PDL))))
			 (Q LOSE))
			(T (LIST (TOPCOPY ACS)
				 (TOPCOPY PDL)
				 (PDLDEPTH))))))))
 
(DFUNC (RST TAG)
 (COND ((NULL TAG) NIL)
       ((ASSOCR TAG GOLIST) (RESTORE PRSSL))
       ((REMPROP TAG (Q SET)) (SAVEACS)
			      (PUTPROP TAG (TOPCOPY PDL) (Q LEVEL))
			      (SETQ MINDEPTH (PDLDEPTH)))
       ((SETQ TAG (SEEKPROP TAG (Q LEVEL))) (RESTORE (PROPVAL TAG)))
       (T (COMPERR NIL-RST))))








(DFUNC (SAVEACS)
       (PROG (K)
	     (SETQ K 0)
	LOOP (COND ((EQ K NACS) (RETURN NIL)))
	     (CPUSH (SETQ K (ADD1 K)))
	     (GO LOOP)))
 
(DFUNC (SETSLOT X Y) (RPLACA (GETSLOT X) Y))
 
(DFUNC (SHRINKPDL C)
       (COND ((NOT (ZEROP C))
	      (AND LASTOUT
		   (EQ (CAAR LASTOUT) (Q SUB))
		   (EQ (CADAR LASTOUT) (Q P))
		   (SETQ C (*PLUS C (CADR (CADDAR LASTOUT))))	→***
		   (SETQ LASTOUT NIL))
	      (OUTINST (LIST (Q SUB) (Q P) (GENCONST C 0 C 0)))))) →***
 
(DFUNC (SIDEEFFECTS FUN) (NOT (HASPROP FUN (Q ACS))))
 
(DFUNC (SLOTCONT X) (CAR (GETSLOT X)))
 
(DFUNC (SLOTLIST) (APPEND ACS PDL))
 
(DFUNC (SLOTPOP)
 (PROGN (SETQ PDLDEPTH (SUB1 PDLDEPTH)) (SETQ PDL (CDR PDL))))
 
(DFUNC (SLOTPUSH SC)
 (PROGN (SETQ PDLDEPTH (ADD1 PDLDEPTH)) (SETQ PDL (CONS SC PDL))))
 
(DFUNC (SPECVARP VAR) (MEMBER VAR SPECVARS))
 
(DFUNC (TRANSOUT OP AC AD)
 (PROG (TEM IND)
       (COND ((OR (ATOM AD) (ATOM (CAR AD))) (GO DONE)))
       (SETQ AD (CAR AD))
       (COND ((SETQ TEM (SEEKPROP OP (Q IMMED)))
	      (SETQ OP (PROPVAL TEM))
	      (GO DONE)))
       (SETQ AD (GENCONST 0 0 AD 0))
  DONE (SETQ IND (COND ((NEEDS AD) (LIST (Q S)))		→***
		       ((OR (NOT (NUMBERP AD)) (GREATERP AD 0)) NIL)
		       (T (LIST (Q P)))))
       (RETURN (MCONS OP AC AD IND))))
 
(DFUNC (USEDTAGP TAG) (HASPROP TAG (Q USED)))
 
 








(MAPDEF PASS2 (EXPR CALLSUBR) (SUBR CALLSUBR) (*SUBR CALLSUBR)
	      (*UNDEF CALLSUBR) (LSUBR CALLLSUBR) (*LSUBR CALLLSUBR)
	      (FEXPR CALLFSUBR) (FSUBR CALLFSUBR) (*FSUBR CALLFSUBR)
	      (FUNVAR CALLFUNARGS) (CARCDR P2CARCDR) (P2 DOP2))
 
(MAPDEF P2 (ARG P2ARG) (*EVAL P2*EVAL) (COND P2COND)
	   (EQ P2EQ) (GO P2GO) (NULL P2NULL)
	   (QUOTE P2QUOTE) (PROG P2PROG) (PROG2 P2PROG2)
	   (RETURN P2RETURN) (RPLACA P2RPLAC) (RPLACD P2RPLAC)
	   (SETARG P2SETARG) (SETQ P2SETQ) (STORE P2STORE))
→***	   ((AND P2BOOL) and (OR P2BOOL) Removed)
 
(MAPDEF BOOL (EQ BOOLEQ) (NULL BOOLNULL) (QUOTE BOOLQUOTE) (COND BOOLCOND))
→***	     ((AND BOOLAND) and (OR BOOLOR) Removed)
 
(SETQ CARCDRDEPTH 4)
 
(PROG (BASE COUNT LIMIT MIDDLE NAME)
      (SETQ BASE 2)
      (SETQ LIMIT (SUB1 (LSH 1 (ADD1 CARCDRDEPTH))))
      (SETQ COUNT (LSH 1 1))
 LOOP (COND ((GREATERP COUNT LIMIT) (RETURN NIL)))
      (SETQ MIDDLE (SUBST (QUOTE A)
			  0
			  (SUBST (QUOTE D) 1 (CDR (EXPLODE COUNT)))))
      (SETQ NAME (READLIST (APPEND (QUOTE (C)) MIDDLE (QUOTE (R)))))
      (PUTPROP NAME
	       (CONS (CAR MIDDLE)
		     (COND ((CDR MIDDLE)
			    (READLIST (APPEND (QUOTE (C))
					      (CDR MIDDLE)
					      (QUOTE (R)))))))
	       (QUOTE CARCDR))
      (SETQ COUNT (ADD1 COUNT))
      (GO LOOP))
 
(MAPDEF ACS (*APPEND 37) (ATOM 1) (CONS 3) (GENSYM 7) (GET 1)
	    (LAST 3) (LENGTH 7) (MEMBER 37) (NCONS 3) (XCONS 3)
	    (CONSP 3) (ASSOC 3) (MEMB 7) (MEMQ 7) (*NCONC 7)	→***
	    (FREE 1) (FREELIST 3) (REVERSE 3) (REMPROP 3))	→***
 
(MAPDEF COMMU (CONS XCONS) (EQUAL EQUAL) (*GREAT *LESS)
	      (*LESS *GREAT) (*PLUS *PLUS) (*TIMES *TIMES)
	      (*MIN *MIN) (*MAX *MAX))				→***
 
(MAPDEF IMMED (CAME CAIE) (CAMN CAIN) (HLLZS@ HLLZS) (HLRZ@ HLRZ)
	      (HRLM@ HRLM) (HRRM@ HRRM) (HRRZ@ HRRZ) (HRRZS@ HRRZS)
	      (MOVE MOVEI))
 
(SETQ NACS 5)
 
(SETQ VALUEAC 1)
 
(SETQ FARGAC 1)
 
(SETQ GOTABAC 1)
 
(SETQ ARRAYAC 1)
 
(SETQ INUM0 (MAKNUM 0 (QUOTE FIXNUM)))
 
(ENDBLOCK PASS2)








(BEGINBLOCK DEBUG)
 
(DFUNC (CMPBREAK TYPE MESSAGE)
       (OUTC (PROG1 (OUTC NIL NIL) (PRINTLEV DEBUGXPR 2)) NIL)
       (ERROR (APPEND TYPE MESSAGE)))				→***
 
(DEFPROP COMPERR
	 (LAMBDA (L) (CMPBREAK (Q (*COMPILER ERROR*)) L))
	 FEXPR)
 
(DFUNC (LAPNOTES) (COPY (MAPCAR (FUNCTION EVAL) TRACELIST)))
 
(DEFPROP USERERR (LAMBDA (L) (CMPBREAK (Q (*USER ERROR*)) L)) FEXPR)
 
(SETQ TRACELIST NIL)
 
(ENDBLOCK DEBUG)
 
(BEGINBLOCK IO)
 
(DFUNC (ATMARGIN) (EQ (CHRCT) (LINELENGTH NIL)))
 
(DFUNC (CARRETN) (COND ((NOT (ATMARGIN)) (LINEF 1))))
 
(DFUNC (LINEF N)
       (PROG NIL
	LOOP (COND ((ZEROP N) (RETURN NIL)))
	     (TERPRI)
	     (SETQ N (SUB1 N))
	     (GO LOOP)))
 
(DFUNC (PRINL L) (MAPC (FUNCTION PRINS) L))
 
(DFUNC (PRINS FN)
 (PROG2	(COND ((GREATERP (ADD1 (FLATSIZE FN)) (CHRCT)) (LINEF 1)))
	(PRINTEXPR FN)))
 
(DFUNC (PRINTEXPR XPR) (PROG2 (PRIN1 XPR) (PRINC @" ")))
 
(DFUNC (PRINTSTAT STAT)
 (PROG2 (COND ((NULL STAT) (CARRETN) (TAB 11))
	      ((ATOM STAT) (TAB 2))
	      ((EQ (CAR STAT) (Q LAP)) (TAB 1))
	      (T (TAB 11)))
	(PRIN1 STAT)))
 
(ENDBLOCK IO)








(BEGINBLOCK GENERAL)
 
(DFUNC (ADDTOLIST X Y) (COND ((MEMBER X Y) Y) (T (CONS X Y))))
 
(DFUNC (ASSOCR X Y)
       (PROG NIL
	LOOP (COND ((NULL Y) (RETURN NIL))
		   ((EQ X (CDAR Y)) (RETURN (CAR Y))))
	     (SETQ Y (CDR Y))
	     (GO LOOP)))
 
(DFUNC (CONSTANTP XPR) (OR (NUMBERP XPR) (MEMB XPR (Q (T NIL)))))
 
(DFUNC (DEINITSYM NAME) (DELETEPROP NAME (Q SYMNO)))
 
(DFUNC (FSUBRP FUN) (GETL FUN (Q (FEXPR *FSUBR FSUBR))))
 
(DFUNC (GETGET ATOM PROP)
       (PROG (TEM PTAB)
	     (SETQ PTAB (FIRSTPROP ATOM))
	LOOP (COND ((LASTPROP PTAB) (RETURN NIL)))
	     (COND ((SETQ TEM (SEEKPROP (PROPNAM PTAB) PROP))
		    (RETURN TEM)))
	     (SETQ PTAB (NEXTPROP PTAB))
	     (GO LOOP)))
 
(DFUNC (INITSYM NAME) (INITPROP NAME (Q SYMNO) 1))
 
(DFUNC (LSUBRP FUN) (GETL FUN (Q (LSUBR *LSUBR))))
 
(DFUNC (MAKESPECIAL VAR)
       (PROG NIL
	     (COND ((HASPROP VAR (Q LOCAL))
		    (SETQ SPECIALS (ADDTOLIST VAR SPECIALS))
		    (PRINTMSG (CONS VAR (Q (LOCAL AND SPECIAL))))))
	     (SETPROP VAR (Q SPECIAL) T)
	     (RETURN VAR)))
 
(DFUNC (MAKESYM IDENT NUMBER)
 (PROG (*NOPOINT)
       (SETQ *NOPOINT T)
       (RETURN (MAKNAM (NCONC (EXPLODE IDENT) (EXPLODE NUMBER))))))
 
(DFUNC (MAKEUNSPECIAL VAR) (COND ((REMPROP VAR (Q SPECIAL)) VAR)))
 
(DFUNC (NEXTSYM NAME)
       (PROG (NUM)
	     (SETQ NUM (GETPROP NAME (Q SYMNO)))
	     (PUTPROP NAME (ADD1 NUM) (Q SYMNO))
	     (RETURN (MAKESYM NAME NUM))))
 
(DFUNC (NTHCDR NUM EXP)
       (PROG NIL
	     (COND ((MINUSP NUM) (COMPERR NEGNUM-NTHCDR)))
	LOOP (COND ((ZEROP NUM) (RETURN EXP)))
	     (COND ((ATOM EXP) (COMPERR ATOM-NTHCDR)))
	     (SETQ EXP (CDR EXP))
	     (SETQ NUM (SUB1 NUM))
	     (GO LOOP)))








(DFUNC (SUBRP FUN) (GETL FUN (Q (EXPR SUBR ARRAY *SUBR *UNDEF))))
 
(DFUNC (TOPCOPY SXP) (APPEND SXP NIL))
 
(BEGINBLOCK PROPTABLE)
 
(DFUNC (DELETEPROP IDENT PROPNAM)
       (PROG (TEM)
	     (SETQ TEM IDENT)
	LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
	     (COND ((EQ (CADR TEM) PROPNAM) (RPLACD TEM (CDDDR TEM))
					    (RETURN T)))
	     (SETQ TEM (CDDR TEM))
	     (GO LOOP)))
 
(DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP)))
 
(DFUNC (INITPROP IDENT PROPNAM PROPVAL)
       (RPLACD IDENT (MCONS PROPNAM PROPVAL (CDR IDENT))))
 
(DFUNC (SEEKPROP IDENT PROPNAM)
       (PROG (TEM)
	     (SETQ TEM (GETL IDENT (LIST PROPNAM)))
	     (COND ((NULL TEM) (RETURN NIL)))
	     (RETURN TEM)))
 
(ENDBLOCK PROPTABLE)
 
(ENDBLOCK GENERAL)
 
(ENDBLOCK COMPILER)








(BEGINBLOCK UCI-ADDITIONS)	→*** (With some Rutgers modifications)
 
(DEFPROP NOCALL
 (LAMBDA (XPR) (EVALFLUSH (LIST @DEFLIST XPR T @NOCALL)))
FEXPR)
 
(DEFPROP EVALFLUSH
 (LAMBDA (XPR) (EVAL XPR) (FLUSHEXPR XPR))
EXPR)
 
(DEFPROP CADDRLAM
 (LAMBDA(EXP)
  (COND ((CDDDR EXP) (CONS @PROGN (CDDR EXP))) (T (CADDR EXP))))
EXPR)
 
(DEFPROP NEEDS
 (LAMBDA(AD)
  (AND (CONSP AD)
       (CADR AD)
       (MEMQ (CAR AD) (QUOTE (QUOTE E SPECIAL)))
       (NOT (*GREAT (MAKNUM (CADR AD) (QUOTE FIXNUM)) 377777))))
EXPR)
 
(DEFPROP P1PROGN
 (LAMBDA (XPR) (CONS (Q PROGN) (MAPP1 (CDR XPR))))
EXPR)
 
(DEFPROP PROGN P1PROGN P1)
 
(DFUNC (P2PROGN XPR VALAC EFFECTS)
       (PROG (ARGS)
	     (COND ((NULL (SETQ ARGS (CDR XPR))) (USERERR NOARGS-P2PROGN)))
	LOOP (COND ((NULL (CDR ARGS))
		    (RETURN (COMPEXPR (CAR ARGS) VALAC EFFECTS))))
	     (COMPE (CAR ARGS) VALAC)
	     (SETQ ARGS (CDR ARGS))
	     (GO LOOP)))
 
(DEFPROP PROGN P2PROGN P2)
 
(DEFPROP NEQ
 (LAMBDA (L) (LIST (QUOTE NOT) (CONS @EQ (CDR L))))
INMACRO)
 
(DEFPROP AND
 (LAMBDA(L)
  (COND ((CDR L)
	 (COND ((CDDR L) (LIST (QUOTE COND) (LIST (CADR L) (CONS @AND (CDDR L))))) (T (CADR L))))
	(T)))
INMACRO)
 
(DEFPROP OR
 (LAMBDA (L) (COND ((CDR L) (CONS (QUOTE COND) (MAPCAR (FUNCTION NCONS) (CDR L))))))
INMACRO)
 
(DEFPROP PROG1
 (LAMBDA(L)
  (COND ((LESSP (LENGTH (CDR L)) 5) (MCONS (Q PROG2) 0 (CDR L)))
	(T (LIST (Q PROG2) 0 (CADR L) (CONS (Q PROG2) (CDDR L))))))
INMACRO)
 
(PUTPROP @SELECTQ T @SPECIAL)
 
(DEFPROP SELECTQ
 (LAMBDA(L)
  (PROG (FIRSTCL RESTCL RSLT)
	(SETQ RSLT (NCONS (QUOTE COND)))
	(COND ((ATOM (CAR (SETQ L (CDR L)))) (SETQ FIRSTCL (SETQ RESTCL (CAR L))))
	      ((EQ (CAAR L) (QUOTE SETQ)) (SETQ FIRSTCL (CAR L)) (SETQ RESTCL (CADAR L)))
	      (T (SETQ FIRSTCL (LIST (QUOTE SETQ) (SETQ RESTCL (QUOTE SELECTQ)) (CAR L)))))
   LP	(COND
	 ((CDR (SETQ L (CDR L))) (NCONC RSLT
					(NCONS
					 (CONS (LIST (COND ((ATOM (CAAR L)) (QUOTE EQ)) (T (QUOTE MEMQ)))
 						     FIRSTCL
						     (LIST (QUOTE QUOTE) (CAAR L)))
					       (CDAR L))))
				 (SETQ FIRSTCL RESTCL)
				 (GO LP)))
	(NCONC RSLT (NCONS (CONS T L)))
	(RETURN RSLT)))
INMACRO)
 
(DEFPROP P1MAPC
 (LAMBDA(XPR)
  (ALLMAP XPR
	  (QUOTE
	   (PROG NIL
	    L1	 (COND
		  ((AND ALLARGS) (FN CARALLARGS)
				 ALLSETQS
				 (GO L1)))))))
EXPR)
 
(DEFPROP P1MAP
 (LAMBDA(XPR)
  (ALLMAP XPR
	  (QUOTE
	   (PROG NIL
	    L1	 (COND
		  ((AND ALLARGS) (FN ALLARGS) ALLSETQS (GO L1)))))))
EXPR)
 
(DEFPROP P1MAPCAR
 (LAMBDA(XPR)
  (ALLMAP
   XPR
   (SUBPAIR
    (QUOTE (TM1 TM2 TM3))
    (LIST (GENVAR) (GENVAR) (GENVAR))
    (QUOTE
     (PROG (TM1 TM2 TM3)
      L1   (COND
	    ((AND ALLARGS)
	     (SETQ TM3 (NCONS (FN CARALLARGS)))
	     (SETQ
	      TM2
	      (COND (TM2 (CDR (RPLACD TM2 TM3))) (T (SETQ TM1 TM3))))
	     ALLSETQS
	     (GO L1)))
	   (RETURN TM1))))))
EXPR)
 
(DEFPROP P1MAPLIST
 (LAMBDA(XPR)
  (ALLMAP
   XPR
   (SUBPAIR
    (QUOTE (TM1 TM2 TM3))
    (LIST (GENVAR) (GENVAR) (GENVAR))
    (QUOTE
     (PROG (TM1 TM2 TM3)
      L1   (COND
	    ((AND ALLARGS)
	     (SETQ TM3 (NCONS (FN ALLARGS)))
	     (SETQ
	      TM2
	      (COND (TM2 (CDR (RPLACD TM2 TM3))) (T (SETQ TM1 TM3))))
	     ALLSETQS
	     (GO L1)))
	   (RETURN TM1))))))
EXPR)
 
(DEFPROP P1MAPCONC
 (LAMBDA(XPR)
  (ALLMAP
   XPR
   (SUBPAIR
    (QUOTE (TM1 TM2 TM3))
    (LIST (GENVAR) (GENVAR) (GENVAR))
    (QUOTE
     (PROG (TM1 TM2 TM3)
      L1   (COND
	    ((AND ALLARGS)
	     (COND
	      ((SETQ TM3 (FN CARALLARGS))
	       (SETQ
		TM2
		(LAST
		 (COND (TM2 (RPLACD TM2 TM3)) (T (SETQ TM1 TM3)))))))
	     ALLSETQS
	     (GO L1)))
	   (RETURN TM1))))))
EXPR)
 
(DEFPROP P1MAPCON
 (LAMBDA(XPR)
  (ALLMAP
   XPR
   (SUBPAIR
    (QUOTE (TM1 TM2 TM3))
    (LIST (GENVAR) (GENVAR) (GENVAR))
    (QUOTE
     (PROG (TM1 TM2 TM3)
      L1   (COND
	    ((AND ALLARGS)
	     (COND
	      ((SETQ TM3 (FN ALLARGS))
	       (SETQ
		TM2
		(LAST
		 (COND (TM2 (RPLACD TM2 TM3)) (T (SETQ TM1 TM3)))))))
	     ALLSETQS
	     (GO L1)))
	   (RETURN TM1))))))
EXPR)
 
(MAPDEF P1 (MAPC P1MAPC) (MAP P1MAP) (MAPCAR P1MAPCAR) (MAPLIST P1MAPLIST)
	   (MAPCONC P1MAPCONC) (MAPCAN P1MAPCONC) (MAPCON P1MAPCON))
 
(DEFPROP ALLMAP
 (LAMBDA(XPR FORM)
  (COND
   ((OR (ATOM (CADR XPR))
	(NOT (MEMQ (CAADR XPR) (QUOTE (QUOTE FUNCTION))))
	(ATOM (CADADR XPR)))
    (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))
   (T
    (P1
     (CONS
      (PROG (TMPS)
	    (SETQ
	     TMPS
	     (MAPCAR (FUNCTION (LAMBDA (X) (GENVAR))) (CDDR XPR)))
	    (RETURN
	     (LIST
	      (QUOTE LAMBDA)
	      TMPS
	      (FORMSUBST
	       (CADADR XPR)
	       TMPS
	       (MAPCAR (FUNCTION (LAMBDA (X) (LIST (QUOTE CAR) X)))
		       TMPS)
	       (MAPCAR
		(FUNCTION
		 (LAMBDA(X)
		  (LIST (QUOTE SETQ) X (LIST (QUOTE CDR) X))))
		TMPS)
	       FORM))))
      (CDDR XPR))))))
EXPR)
 
(DEFPROP FORMSUBST
 (LAMBDA(FN ALLARGS CARALLARGS ALLSETQS FORM)
  (COND ((ATOM FORM) FORM)
	((ATOM (CAR FORM))
	 (NCONC (SELECTQ (CAR FORM)
			 (FN (NCONS FN))
			 (ALLARGS (COPY ALLARGS))
			 (CARALLARGS (COPY CARALLARGS))
			 (ALLSETQS (COPY ALLSETQS))
			 (NCONS (CAR FORM)))
		(FORMSUBST FN
			   ALLARGS
			   CARALLARGS
			   ALLSETQS
			   (CDR FORM))))
	(T
	 (CONS (FORMSUBST FN ALLARGS CARALLARGS ALLSETQS (CAR FORM))
	       (FORMSUBST FN
			  ALLARGS
			  CARALLARGS
			  ALLSETQS
			  (CDR FORM))))))
EXPR)
 
(DEFPROP P2MAPC
 (LAMBDA(XPR VALAC EFFECTS)
  (COND ((EQ (LENGTH (CDR XPR)) 2)
	 (RPLACA XPR (QUOTE *MAPC))
	 (PROG1 (CALLSUBR XPR VALAC EFFECTS) (RPLACA LASTOUT (QUOTE (PUSHJ P *MAPC)))))
	(T (CALLLSUBR XPR VALAC EFFECTS))))
EXPR)
 
(DEFPROP P2MAP
 (LAMBDA(XPR VALAC EFFECTS)
  (COND ((EQ (LENGTH (CDR XPR)) 2)
	 (RPLACA XPR (QUOTE *MAP))
	 (PROG1 (CALLSUBR XPR VALAC EFFECTS) (RPLACA LASTOUT (QUOTE (PUSHJ P *MAP)))))
	(T (CALLLSUBR XPR VALAC EFFECTS))))
EXPR)
 
(MAPDEF P2 (MAPC P2MAPC) (MAP P2MAP))
 
(ENDBLOCK UCI-ADDITIONS)








(BEGINBLOCK RUTGERS-ADDITIONS)
 
(DEFPROP DO
 (LAMBDA (L)
  (CONS @PROGN (CDR L)))
INMACRO)
 
(DEFPROP * (LAMBDA (L) NIL) INMACRO)
 
(DEFPROP ** (LAMBDA (L) NIL) INMACRO)
 
(DEFPROP *** (LAMBDA (L) NIL) INMACRO)
 
(DEFPROP CATCH
 (LAMBDA (L)
  (SETQ L (CDR L))
  (COND [(NULL (CDR L)) (LIST @PROGN (LIST @%CATCH (CONS @ERRSET L)) @THROW)]
	[(ATOM (CADR L))
	 (LIST @COND
	       (LIST (LIST @OR
			   (LIST @%CATCH (LIST @ERRSET (CAR L)))
			   (LIST @EQ @CATCH (CONS @QUOTE (CDR L))))
		     @THROW)
	       @(T (ERR @THROW)))]
	[T (LIST @COND
		 (LIST (LIST @%CATCH (LIST @ERRSET (CAR L))) @THROW)
		 (LIST T
		       (CONS @SELECTQ
			     (CONS @CATCH (APPEND (CDR L) @((ERR @THROW)))))))]))
INMACRO)
 
(DEFPROP THROW
 (LAMBDA (L)
  (LIST @PROGN
	(LIST @SETQ @THROW (CADR L))
	(LIST @SETQ @CATCH (AND [CDDR L] [LIST @QUOTE (CADDR L)]))
	@(ERR @THROW)))
INMACRO)
 
(DEFLIST (CATCH THROW) T SPECIAL)
 
(DEFPROP NCONC
 (LAMBDA (L)
  (COND [(NULL (CDR L)) NIL]
	[(NULL (CDDR L)) (CADR L)]
	[T (LIST @*NCONC (CADR L) (CONS (CAR L) (CDDR L)))]))
INMACRO)
 
(DEFPROP RPTQ
 (LAMBDA (L)
  (SUBPAIR @(NEXPR NTMP EXPR ETMP)
	   (LIST (CADR L) (GENVAR) (CADDR L) (GENVAR))
	   @((LAMBDA (NTMP RPTN)
	      (PROG (ETMP)
	       LOOP (AND [*GREAT RPTN NTMP] [RETURN ETMP])
		    (SETQ ETMP EXPR)
		    (SETQ RPTN (ADD1 RPTN))
		    (GO LOOP)))
	     NEXPR
	     1Q)))
INMACRO)
 
(PUTPROP @RPTN T @SPECIAL)
 
(DEFPROP MSG
 (LAMBDA (L)
  (NCONC
   (CONS @PROGN
	(MAPCAR (FUNCTION (LAMBDA (X)
			   (COND [(EQ X T) @(TERPRI)]
				 [(NUMBERP X) (LIST @SPACES X)]
				 [(STRINGP X) (LIST @PRINAC (LIST @QUOTE X))]
				 [(AND [CONSP X] [EQ (CAR X) @E]) (CADR X)]
				 [(AND [CONSP X] [EQ (CAR X) @T])
				  (LIST @TAB (CADR X))]
				 [T (LIST @PRINA X)])))
		(CDR L)))
   @(NIL)))
INMACRO)
 
(DEFPROP TTYMSG
 (LAMBDA (L)
  (LIST @OUTC (LIST @PROG1 @(OUTC NIL NIL) @(TALK) (CONS @MSG (CDR L))) NIL))
INMACRO)
 
(DEFPROP MAPATOMS
 (LAMBDA (L)
  (SUBPAIR @(FN TM1)
	   (LIST (CADR L) (GENVAR))
	   @(MAPC (FUNCTION (LAMBDA (TM1)
			     (MAPC FN TM1)))
		  OBLIST)))
INMACRO)
 
(PUTPROP @OBLIST T @SPECIAL)
 
(DEFPROP NOTANY
 (LAMBDA (L)
  (LIST @NOT (CONS @SOME (CDR L))))
INMACRO)
 
(DEFPROP NOTEVERY
 (LAMBDA (L)
  (LIST @NOT (CONS @EVERY (CDR L))))
INMACRO)
 
(DEFPROP P1SUBSET
 (LAMBDA (XPR)
  (COND [(NEQ (LENGTH (CDR XPR)) 2Q) (USERERR ARGNO-P1SUBSET)])
  (ALLMAP XPR
	  (SUBPAIR @(TM1 TM2)
		   (LIST (GENVAR) (GENVAR))
		   @(PROG (TM1 TM2)
		       L1 (COND [(NULL ALLARGS) (RETURN TM1)]
				[(NOT (FN CARALLARGS))]
				[(NULL TM1)
				 (SETQ TM1 (SETQ TM2 (NCONS CARALLARGS)))]
				[T (SETQ TM2
					 (CDR (RPLACD TM2 (NCONS CARALLARGS))))])
			  ALLSETQS
			  (GO L1)))))
EXPR)
 
(DEFPROP P1EVERY
 (LAMBDA (XPR)
  (COND [(NEQ (LENGTH (CDR XPR)) 2Q) (USERERR ARGNO-P1EVERY)])
  (ALLMAP XPR
	  @(PROG NIL
	      L1 (COND [(NULL ALLARGS) (RETURN T)]
		       [(FN CARALLARGS) ALLSETQS (GO L1)]))))
EXPR)
 
(DEFPROP P1SOME
 (LAMBDA (XPR)
  (COND [(NEQ (LENGTH (CDR XPR)) 2Q) (USERERR ARGNO-P1SOME)])
  (ALLMAP XPR
	  @(PROG NIL
	      L1 (COND [(NULL ALLARGS) (RETURN NIL)]
		       [(FN CARALLARGS) (RETURN ALLARGS)]
		       [T ALLSETQS (GO L1)]))))
EXPR)
 
(MAPDEF P1 (SUBSET P1SUBSET) (EVERY P1EVERY) (SOME P1SOME))
 
(DEFPROP P1APPLY
 (LAMBDA (XPR)
  (PROG (CDRXPR)
	(SETQ CDRXPR (P1SUBRARGS (CDR XPR)))
	(RETURN (CONS (COND [(CDDR CDRXPR) @APPLY] [T @*APPLY]) CDRXPR))))
EXPR)
 
(DEFPROP APPLY P1APPLY P1)
 
(DEFPROP P2APPLY#
 (LAMBDA (XPR VALAC EFFECTS)
  (PROG (TEM)
	(COND [(AND [EQ (CAADR XPR) @QUOTE]
		    [GETL (SETQ TEM (CADADR XPR)) @(FEXPR FSUBR *FSUBR)])
	       (GO FAST)]
	      [T (RETURN (CALLSUBR XPR VALAC EFFECTS))])
   FAST	(LOADCOMP (CADDR XPR) FARGAC)
	(CLEAR2BOTH)
	(PROTECTACS TEM)
	(OUTCALL 17Q TEM)
	(RETURN (MARKVAL VALUEAC EFFECTS))))
EXPR)
 
(DEFPROP APPLY# P2APPLY# P2)
 
(DEFPROP P1ERRSET
 (LAMBDA (XPR)
  (PROG (INPROG)
	(RETURN (CONS @ERRSET (CONS (P1 (CADR XPR)) (CDDR XPR))))))
EXPR)
 
(DEFPROP ERRSET P1ERRSET P1)
 
(DEFPROP P2ERRSET
 (LAMBDA (XPR VALAC EFFECTS)
  (PROG (HOME INST RETTAG VAL)
	(CLEAR1)
	(SLOTPUSH @(NIL . TAKEN))
	(OUTPUSH (GENCONST 0Q 0Q (SETQ RETTAG (GENTAG)) 0Q))
	(LOADARG VALUEAC (CONS @QUOTE (OR [CDDR XPR] @[T])))
	(SLOTPUSH @(NIL . TAKEN))
	(SLOTPUSH @(NIL . TAKEN))
	(SLOTPUSH @(NIL . TAKEN))
	(SLOTPUSH @(NIL . TAKEN))
	(SLOTPUSH @(NIL . TAKEN))
	(OUTINST @(JSP 13Q *ERRSET1))
	(SETQ HOME (TOPCOPY PDL))
	(LOADARG VALUEAC (SETQ INST (COMP (CADR XPR) VALUEAC)))
	(RESTORE HOME)
	(REMOVE INST)
	(PROGN (SLOTPOP) (SLOTPOP) (SLOTPOP) (SLOTPOP) (SLOTPOP) (SLOTPOP))
	(CLEAR2BOTH)
	(CLEARACS)
	(SETQ VAL (MARKVAL VALUEAC EFFECTS))
	(OUTINST @(JRST 0Q *ERRSET2))
	(OUTTAG RETTAG)
	(RETURN VAL)))
EXPR)
 
(DEFPROP ERRSET P2ERRSET P2)
 
(DEFPROP IGNORE (LAMBDA (L) NIL) EXPR)
 
(DEFPROP CALL
 (LAMBDA (L)
  (FLUSHEXPR (LIST @DEFLIST L T @CALL)))
FEXPR)
 
(DEFPROP *SUBR
 (LAMBDA (L)
  (APPLY# @DEFLIST (LIST L T @*SUBR)))
FEXPR)
 
(DEFPROP *FSUBR
 (LAMBDA (L)
  (APPLY# @DEFLIST (LIST L T @*FSUBR)))
FEXPR)
 
(DEFPROP *LSUBR
 (LAMBDA (L)
  (APPLY# @DEFLIST (LIST L T @*LSUBR)))
FEXPR)
 
(DEFPROP GLOBALMACRO
 (LAMBDA (L)
  (APPLY# @DEFLIST (LIST L T @GLOBALMACRO)))
FEXPR)
 
(DEFP *EXPR *SUBR FSUBR)
 
(DEFP *FEXPR *FSUBR FSUBR)
 
(DEFP *LEXPR *LSUBR FSUBR)
 
(ENDBLOCK RUTGERS-ADDITIONS)

.